From c45ccbbc24d3de0e27fccd645682a41cc8e05650 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Apr 2007 12:39:10 -0500 Subject: [PATCH 001/886] special case netbsd64 gcc3-4 --- misc/factor.sh | 3 +++ 1 file changed, 3 insertions(+) diff --git a/misc/factor.sh b/misc/factor.sh index 276956b0b7..9d4f26fa46 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -88,6 +88,9 @@ set_md5sum() { set_gcc() { case $OS in openbsd) ensure_program_installed egcc; CC=egcc;; + netbsd) if [[ $WORD -eq 64 ]] ; then + CC=/usr/pkg/gcc34/bin/gcc + fi ;; *) CC=gcc;; esac } From f1e17f290656ba845cb2849a531b79e7af8d22be Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Apr 2007 20:04:39 -0500 Subject: [PATCH 002/886] fix netbsd64 target --- build-support/target | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-support/target b/build-support/target index 8e07c1afdc..1903a6da64 100755 --- a/build-support/target +++ b/build-support/target @@ -15,7 +15,7 @@ then elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = i386 \) ] then echo netbsd-x86-32 -elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = amd64 \) ] +elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = x86_64 \) ] then echo netbsd-x86-64 elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ] From 4ecd7fff4237df32f2409f7ee16db16d32cd57f6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Apr 2007 04:27:15 -0500 Subject: [PATCH 003/886] split up some unix constants split up netbsd stat --- extra/unix/bsd/bsd.factor | 11 +++++++--- extra/unix/bsd/freebsd/freebsd.factor | 3 +++ extra/unix/bsd/macosx/macosx.factor | 3 +++ extra/unix/bsd/netbsd/netbsd.factor | 3 +++ extra/unix/bsd/openbsd/openbsd.factor | 3 +++ extra/unix/stat/netbsd/32/32.factor | 26 ++++++++++++++++++++++++ extra/unix/stat/netbsd/64/64.factor | 27 +++++++++++++++++++++++++ extra/unix/stat/netbsd/netbsd.factor | 29 +++++---------------------- extra/unix/types/netbsd/netbsd.factor | 5 ++--- extra/unix/unix.factor | 1 - 10 files changed, 80 insertions(+), 31 deletions(-) create mode 100644 extra/unix/bsd/freebsd/freebsd.factor create mode 100644 extra/unix/bsd/macosx/macosx.factor create mode 100644 extra/unix/bsd/netbsd/netbsd.factor create mode 100644 extra/unix/bsd/openbsd/openbsd.factor create mode 100644 extra/unix/stat/netbsd/32/32.factor create mode 100644 extra/unix/stat/netbsd/64/64.factor diff --git a/extra/unix/bsd/bsd.factor b/extra/unix/bsd/bsd.factor index e652f1b9f9..cb7b347c20 100755 --- a/extra/unix/bsd/bsd.factor +++ b/extra/unix/bsd/bsd.factor @@ -1,7 +1,7 @@ ! 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 @@ -15,8 +15,6 @@ USING: alien.syntax ; : 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 @@ -83,3 +81,10 @@ C-STRUCT: sockaddr-un : 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 diff --git a/extra/unix/bsd/freebsd/freebsd.factor b/extra/unix/bsd/freebsd/freebsd.factor new file mode 100644 index 0000000000..94bb708527 --- /dev/null +++ b/extra/unix/bsd/freebsd/freebsd.factor @@ -0,0 +1,3 @@ +IN: unix + +: FD_SETSIZE 1024 ; diff --git a/extra/unix/bsd/macosx/macosx.factor b/extra/unix/bsd/macosx/macosx.factor new file mode 100644 index 0000000000..3c0617ad17 --- /dev/null +++ b/extra/unix/bsd/macosx/macosx.factor @@ -0,0 +1,3 @@ +IN: unix + +: FD_SETSIZE 1024 ; inline diff --git a/extra/unix/bsd/netbsd/netbsd.factor b/extra/unix/bsd/netbsd/netbsd.factor new file mode 100644 index 0000000000..ac18749830 --- /dev/null +++ b/extra/unix/bsd/netbsd/netbsd.factor @@ -0,0 +1,3 @@ +IN: unix + +: FD_SETSIZE 256 ; inline diff --git a/extra/unix/bsd/openbsd/openbsd.factor b/extra/unix/bsd/openbsd/openbsd.factor new file mode 100644 index 0000000000..3c0617ad17 --- /dev/null +++ b/extra/unix/bsd/openbsd/openbsd.factor @@ -0,0 +1,3 @@ +IN: unix + +: FD_SETSIZE 1024 ; inline diff --git a/extra/unix/stat/netbsd/32/32.factor b/extra/unix/stat/netbsd/32/32.factor new file mode 100644 index 0000000000..bb2df6d6d3 --- /dev/null +++ b/extra/unix/stat/netbsd/32/32.factor @@ -0,0 +1,26 @@ +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 stat ( char* pathname, stat* buf ) ; +FUNCTION: int lstat ( char* pathname, stat* buf ) ; diff --git a/extra/unix/stat/netbsd/64/64.factor b/extra/unix/stat/netbsd/64/64.factor new file mode 100644 index 0000000000..f1f6f93dbd --- /dev/null +++ b/extra/unix/stat/netbsd/64/64.factor @@ -0,0 +1,27 @@ +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" } + { "int" "__pad5" } ; + +FUNCTION: int stat ( char* pathname, stat* buf ) ; +FUNCTION: int lstat ( char* pathname, stat* buf ) ; diff --git a/extra/unix/stat/netbsd/netbsd.factor b/extra/unix/stat/netbsd/netbsd.factor index bb2df6d6d3..8057e5939b 100644 --- a/extra/unix/stat/netbsd/netbsd.factor +++ b/extra/unix/stat/netbsd/netbsd.factor @@ -1,26 +1,7 @@ -USING: kernel alien.syntax math ; +USING: layouts combinators vocabs.loader ; 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 stat ( char* pathname, stat* buf ) ; -FUNCTION: int lstat ( char* pathname, stat* buf ) ; +cell-bits { + { 32 [ "unix.stat.netbsd.32" require ] } + { 64 [ "unix.stat.netbsd.64" require ] } +} case diff --git a/extra/unix/types/netbsd/netbsd.factor b/extra/unix/types/netbsd/netbsd.factor index 77636a6d6d..6d33547627 100755 --- a/extra/unix/types/netbsd/netbsd.factor +++ b/extra/unix/types/netbsd/netbsd.factor @@ -18,7 +18,7 @@ TYPEDEF: ulonglong u_int64_t TYPEDEF: __uint32_t __dev_t TYPEDEF: __uint32_t dev_t -TYPEDEF: __uint64_t ino_t +TYPEDEF: __uint32_t ino_t TYPEDEF: __uint32_t mode_t TYPEDEF: __uint32_t nlink_t TYPEDEF: __uint32_t uid_t @@ -26,7 +26,6 @@ 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: longlong ssize_t TYPEDEF: int pid_t TYPEDEF: int time_t diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 09d77fee11..d02e180cff 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -149,6 +149,5 @@ FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; { [ linux? ] [ "unix.linux" require ] } { [ bsd? ] [ "unix.bsd" require ] } { [ solaris? ] [ "unix.solaris" require ] } - { [ t ] [ ] } } cond From b993a1c588c5bf091e353d84bd3295081f3e05f2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Apr 2007 04:27:28 -0500 Subject: [PATCH 004/886] more constants --- build-support/grovel.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/build-support/grovel.c b/build-support/grovel.c index 8422ec197c..1260b29c80 100644 --- a/build-support/grovel.c +++ b/build-support/grovel.c @@ -141,10 +141,12 @@ void unix_constants() constant(EINTR); constant(EAGAIN); constant(EINPROGRESS); - constant(PROT_READ); + constant(PROT_READ); constant(PROT_WRITE); constant(MAP_FILE); constant(MAP_SHARED); + grovel(pid_t); + } int main() { @@ -158,6 +160,10 @@ int main() { openbsd_stat(); openbsd_types(); #endif + grovel(blkcnt_t); + grovel(blksize_t); + //grovel(fflags_t); + grovel(ssize_t); #ifdef UNIX unix_types(); From 4c449296b207fba5ba4de2125e0e6beb5ef93292 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Mar 2008 11:18:32 -0500 Subject: [PATCH 005/886] Fix NetBSD FFI --- core/cpu/x86/architecture/architecture.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index 49b05ea48f..f993639c05 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -156,7 +156,7 @@ M: x86-backend %unbox-small-struct ( size -- ) M: x86-backend 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 ; From aad587d6647607042bbbed72e59cbbb67d801c46 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Mar 2008 11:48:51 -0500 Subject: [PATCH 006/886] Fix deploy test --- extra/tools/deploy/deploy-tests.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 8db34320de..5030763a3d 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -1,10 +1,11 @@ IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config tools.deploy.backend math sequences io.launcher arrays -namespaces ; +namespaces continuations ; : shake-and-bake ( vocab -- ) - "." resource-path [ + [ "test.image" temp-file delete-file ] ignore-errors + "resource:" [ >r vm "test.image" temp-file r> dup deploy-config make-deploy-image From ea94662abd7abe4b19ccd6e0a7eaf17211792db2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Apr 2007 05:49:09 -0500 Subject: [PATCH 007/886] NetBSD x86/64 fixes --- vm/{os-linux-x86-32.h => os-linux-x86.32.h} | 0 vm/{os-linux-x86-64.h => os-linux-x86.64.h} | 0 vm/os-netbsd-x86.32.h | 3 +++ vm/os-netbsd-x86.64.h | 4 ++++ vm/os-netbsd.h | 1 - vm/platform.h | 13 +++++++++++-- 6 files changed, 18 insertions(+), 3 deletions(-) rename vm/{os-linux-x86-32.h => os-linux-x86.32.h} (100%) rename vm/{os-linux-x86-64.h => os-linux-x86.64.h} (100%) create mode 100644 vm/os-netbsd-x86.32.h create mode 100644 vm/os-netbsd-x86.64.h diff --git a/vm/os-linux-x86-32.h b/vm/os-linux-x86.32.h similarity index 100% rename from vm/os-linux-x86-32.h rename to vm/os-linux-x86.32.h diff --git a/vm/os-linux-x86-64.h b/vm/os-linux-x86.64.h similarity index 100% rename from vm/os-linux-x86-64.h rename to vm/os-linux-x86.64.h diff --git a/vm/os-netbsd-x86.32.h b/vm/os-netbsd-x86.32.h new file mode 100644 index 0000000000..ca4a9f88f5 --- /dev/null +++ b/vm/os-netbsd-x86.32.h @@ -0,0 +1,3 @@ +#include + +#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap)) diff --git a/vm/os-netbsd-x86.64.h b/vm/os-netbsd-x86.64.h new file mode 100644 index 0000000000..587dc85ec7 --- /dev/null +++ b/vm/os-netbsd-x86.64.h @@ -0,0 +1,4 @@ +#include + +#define ucontext_stack_pointer(uap) \ + ((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP])) diff --git a/vm/os-netbsd.h b/vm/os-netbsd.h index e282828577..b42c6b9d7e 100644 --- a/vm/os-netbsd.h +++ b/vm/os-netbsd.h @@ -1,6 +1,5 @@ #include -#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) diff --git a/vm/platform.h b/vm/platform.h index cd2b6e0a0e..7678d483d6 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -67,20 +67,29 @@ #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 From d7872708a0d36fcc70290d23b94659ca7efed5a1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Apr 2007 06:13:34 -0500 Subject: [PATCH 008/886] Fix 64-bit stat --- extra/unix/stat/netbsd/64/64.factor | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/extra/unix/stat/netbsd/64/64.factor b/extra/unix/stat/netbsd/64/64.factor index f1f6f93dbd..46ab43eeca 100644 --- a/extra/unix/stat/netbsd/64/64.factor +++ b/extra/unix/stat/netbsd/64/64.factor @@ -20,8 +20,10 @@ C-STRUCT: stat { "uint32_t" "st_flags" } { "uint32_t" "st_gen" } { "uint32_t" "st_spare0" } - { "timespec" "st_birthtim" } - { "int" "__pad5" } ; + { "timespec" "st_birthtim" } ; -FUNCTION: int stat ( char* pathname, stat* buf ) ; -FUNCTION: int lstat ( char* pathname, stat* buf ) ; +FUNCTION: int __stat13 ( char* pathname, stat* buf ) ; +FUNCTION: int __lstat13 ( char* pathname, stat* buf ) ; + +: stat __stat13 ; inline +: lstat __lstat13 ; inline From 0a34198912cc6b4c7054c661d8861e0faa4cb4cc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Apr 2007 06:24:02 -0500 Subject: [PATCH 009/886] Working on kqueue --- extra/unix/kqueue/freebsd/freebsd.factor | 13 +++++++++++++ extra/unix/kqueue/kqueue.factor | 15 +++------------ extra/unix/kqueue/macosx/macosx.factor | 13 +++++++++++++ extra/unix/kqueue/netbsd/netbsd.factor | 14 ++++++++++++++ extra/unix/kqueue/openbsd/openbsd.factor | 14 ++++++++++++++ 5 files changed, 57 insertions(+), 12 deletions(-) create mode 100644 extra/unix/kqueue/freebsd/freebsd.factor create mode 100644 extra/unix/kqueue/macosx/macosx.factor create mode 100644 extra/unix/kqueue/netbsd/netbsd.factor create mode 100644 extra/unix/kqueue/openbsd/openbsd.factor diff --git a/extra/unix/kqueue/freebsd/freebsd.factor b/extra/unix/kqueue/freebsd/freebsd.factor new file mode 100644 index 0000000000..4cc539daa3 --- /dev/null +++ b/extra/unix/kqueue/freebsd/freebsd.factor @@ -0,0 +1,13 @@ +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 ) ; diff --git a/extra/unix/kqueue/kqueue.factor b/extra/unix/kqueue/kqueue.factor index 4e6504470d..8166052b01 100644 --- a/extra/unix/kqueue/kqueue.factor +++ b/extra/unix/kqueue/kqueue.factor @@ -1,21 +1,12 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.syntax system sequences vocabs.loader ; IN: unix.kqueue +<< "unix.kqueue." os append require >> + FUNCTION: int kqueue ( ) ; -FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ; - -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 diff --git a/extra/unix/kqueue/macosx/macosx.factor b/extra/unix/kqueue/macosx/macosx.factor new file mode 100644 index 0000000000..4cc539daa3 --- /dev/null +++ b/extra/unix/kqueue/macosx/macosx.factor @@ -0,0 +1,13 @@ +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 ) ; diff --git a/extra/unix/kqueue/netbsd/netbsd.factor b/extra/unix/kqueue/netbsd/netbsd.factor new file mode 100644 index 0000000000..7e97f3bcff --- /dev/null +++ b/extra/unix/kqueue/netbsd/netbsd.factor @@ -0,0 +1,14 @@ +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 ) ; + diff --git a/extra/unix/kqueue/openbsd/openbsd.factor b/extra/unix/kqueue/openbsd/openbsd.factor new file mode 100644 index 0000000000..7e97f3bcff --- /dev/null +++ b/extra/unix/kqueue/openbsd/openbsd.factor @@ -0,0 +1,14 @@ +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 ) ; + From 857a442e072704e54acbe9a1d112dac08c89a6a4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Mar 2008 13:10:51 -0500 Subject: [PATCH 010/886] fix struct sizes fix file-info --- extra/unix/stat/netbsd/32/32.factor | 7 +++++-- extra/unix/types/netbsd/32/32.factor | 6 ++++++ extra/unix/types/netbsd/64/64.factor | 6 ++++++ extra/unix/types/netbsd/netbsd.factor | 11 ++++++++--- 4 files changed, 25 insertions(+), 5 deletions(-) create mode 100755 extra/unix/types/netbsd/32/32.factor create mode 100755 extra/unix/types/netbsd/64/64.factor diff --git a/extra/unix/stat/netbsd/32/32.factor b/extra/unix/stat/netbsd/32/32.factor index bb2df6d6d3..d4b39a90d1 100644 --- a/extra/unix/stat/netbsd/32/32.factor +++ b/extra/unix/stat/netbsd/32/32.factor @@ -22,5 +22,8 @@ C-STRUCT: stat { "uint32_t" "st_gen" } { { "uint32_t" 2 } "st_qspare" } ; -FUNCTION: int stat ( char* pathname, stat* buf ) ; -FUNCTION: int lstat ( char* pathname, stat* buf ) ; +FUNCTION: int __stat30 ( char* pathname, stat* buf ) ; +FUNCTION: int __lstat30 ( char* pathname, stat* buf ) ; + +: stat __stat30 ; +: lstat __lstat30 ; diff --git a/extra/unix/types/netbsd/32/32.factor b/extra/unix/types/netbsd/32/32.factor new file mode 100755 index 0000000000..892626c416 --- /dev/null +++ b/extra/unix/types/netbsd/32/32.factor @@ -0,0 +1,6 @@ +USING: alien.syntax ; +IN: unix.types + +! NetBSD 4.0 + +TYPEDEF: __uint64_t ino_t diff --git a/extra/unix/types/netbsd/64/64.factor b/extra/unix/types/netbsd/64/64.factor new file mode 100755 index 0000000000..e475bd449b --- /dev/null +++ b/extra/unix/types/netbsd/64/64.factor @@ -0,0 +1,6 @@ +USING: alien.syntax ; +IN: unix.types + +! NetBSD 4.0 + +TYPEDEF: __uint32_t ino_t diff --git a/extra/unix/types/netbsd/netbsd.factor b/extra/unix/types/netbsd/netbsd.factor index 6d33547627..5b54928d95 100755 --- a/extra/unix/types/netbsd/netbsd.factor +++ b/extra/unix/types/netbsd/netbsd.factor @@ -1,4 +1,4 @@ -USING: alien.syntax ; +USING: alien.syntax combinators layouts vocabs.loader ; IN: unix.types ! NetBSD 4.0 @@ -18,7 +18,6 @@ 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 @@ -26,6 +25,12 @@ TYPEDEF: __uint32_t gid_t TYPEDEF: __int64_t off_t TYPEDEF: __int64_t blkcnt_t TYPEDEF: __uint32_t blksize_t -TYPEDEF: longlong ssize_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 + From e61f63b2c9a6e9e4487949a69d5ab0db001c596d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Apr 2007 07:21:12 -0500 Subject: [PATCH 011/886] More kqueue changes --- extra/unix/kqueue/freebsd/freebsd.factor | 10 ++++++++++ extra/unix/kqueue/kqueue.factor | 10 ---------- extra/unix/kqueue/macosx/macosx.factor | 10 ++++++++++ extra/unix/kqueue/netbsd/netbsd.factor | 8 ++++++++ extra/unix/kqueue/openbsd/openbsd.factor | 7 +++++++ 5 files changed, 35 insertions(+), 10 deletions(-) diff --git a/extra/unix/kqueue/freebsd/freebsd.factor b/extra/unix/kqueue/freebsd/freebsd.factor index 4cc539daa3..edddae2c16 100644 --- a/extra/unix/kqueue/freebsd/freebsd.factor +++ b/extra/unix/kqueue/freebsd/freebsd.factor @@ -11,3 +11,13 @@ C-STRUCT: kevent ; 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 diff --git a/extra/unix/kqueue/kqueue.factor b/extra/unix/kqueue/kqueue.factor index 8166052b01..55b53bd6d0 100644 --- a/extra/unix/kqueue/kqueue.factor +++ b/extra/unix/kqueue/kqueue.factor @@ -7,16 +7,6 @@ IN: unix.kqueue FUNCTION: int kqueue ( ) ; -: 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 - ! actions : EV_ADD HEX: 1 ; inline ! add event to kq (implies enable) : EV_DELETE HEX: 2 ; inline ! delete event from kq diff --git a/extra/unix/kqueue/macosx/macosx.factor b/extra/unix/kqueue/macosx/macosx.factor index 4cc539daa3..7dc2a79c09 100644 --- a/extra/unix/kqueue/macosx/macosx.factor +++ b/extra/unix/kqueue/macosx/macosx.factor @@ -11,3 +11,13 @@ C-STRUCT: kevent ; 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 diff --git a/extra/unix/kqueue/netbsd/netbsd.factor b/extra/unix/kqueue/netbsd/netbsd.factor index 7e97f3bcff..e3fc11a688 100644 --- a/extra/unix/kqueue/netbsd/netbsd.factor +++ b/extra/unix/kqueue/netbsd/netbsd.factor @@ -12,3 +12,11 @@ C-STRUCT: kevent 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 diff --git a/extra/unix/kqueue/openbsd/openbsd.factor b/extra/unix/kqueue/openbsd/openbsd.factor index 7e97f3bcff..70b75f42bd 100644 --- a/extra/unix/kqueue/openbsd/openbsd.factor +++ b/extra/unix/kqueue/openbsd/openbsd.factor @@ -12,3 +12,10 @@ C-STRUCT: kevent FUNCTION: int kevent ( int kq, kevent* changelist, size_t nchanges, kevent* eventlist, size_t 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 From 6778362ae74dc1d07734e272ca6bd1e91598f346 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 23 Mar 2008 11:34:48 -0500 Subject: [PATCH 012/886] Fix OpenBSD kqueue --- extra/unix/kqueue/openbsd/openbsd.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/unix/kqueue/openbsd/openbsd.factor b/extra/unix/kqueue/openbsd/openbsd.factor index 70b75f42bd..bc4be88c42 100644 --- a/extra/unix/kqueue/openbsd/openbsd.factor +++ b/extra/unix/kqueue/openbsd/openbsd.factor @@ -2,15 +2,15 @@ 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 + { "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, size_t nchanges, kevent* eventlist, size_t nevents, timespec* timeout ) ; +FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ; : EVFILT_READ -1 ; inline : EVFILT_WRITE -2 ; inline From e20e98133216e31e83f2f8514a5e1e340f2f78b1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 23 Mar 2008 11:38:26 -0500 Subject: [PATCH 013/886] fix temp-file --- core/io/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index cb80f98a50..48098e612d 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -278,7 +278,7 @@ DEFER: copy-tree-into prepend-path ; : temp-directory ( -- path ) - "resource:temp" dup make-directories ; + "temp" resource-path dup make-directories ; : temp-file ( name -- path ) temp-directory prepend-path ; From da3e9c2fb64805ad9b4c4ac25344911a15c84d5b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Apr 2007 07:35:29 -0500 Subject: [PATCH 014/886] add constant --- build-support/grovel.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/build-support/grovel.c b/build-support/grovel.c index 1260b29c80..2eee054dab 100644 --- a/build-support/grovel.c +++ b/build-support/grovel.c @@ -1,4 +1,5 @@ #include +#include #if defined(__FreeBSD__) #define BSD @@ -165,6 +166,8 @@ int main() { //grovel(fflags_t); grovel(ssize_t); + grovel(size_t); + grovel(struct kevent); #ifdef UNIX unix_types(); unix_constants(); From f50821af6e14025dcd049601645dfaf17a62e014 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Wed, 12 Mar 2008 02:11:03 -0700 Subject: [PATCH 015/886] Implement sequence matching in extra/match. --- extra/match/match.factor | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/extra/match/match.factor b/extra/match/match.factor index 722c330a32..36af5c990a 100755 --- a/extra/match/match.factor +++ b/extra/match/match.factor @@ -65,3 +65,26 @@ MACRO: match-cond ( assoc -- ) -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 ] 2apply < [ 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 ; + From 56afb67bfc22f72b712a4e196f4fed6be77ea4fa Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 14 Mar 2008 03:09:51 -0500 Subject: [PATCH 016/886] Unicode encoding changes --- core/io/encodings/binary/binary.factor | 7 +- core/io/encodings/encodings.factor | 126 ++++++++---------- core/io/encodings/utf8/utf8.factor | 94 ++++++-------- core/io/streams/string/string.factor | 4 +- extra/io/encodings/ascii/ascii.factor | 20 +-- extra/io/encodings/latin1/latin1.factor | 10 +- extra/io/encodings/utf16/utf16.factor | 163 ++++++++++-------------- 7 files changed, 187 insertions(+), 237 deletions(-) diff --git a/core/io/encodings/binary/binary.factor b/core/io/encodings/binary/binary.factor index b8bcc0f87a..5038628ed9 100644 --- a/core/io/encodings/binary/binary.factor +++ b/core/io/encodings/binary/binary.factor @@ -1,3 +1,8 @@ ! 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 drop ; +M: binary drop ; diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 2f68334bde..b7c71d5527 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -2,62 +2,36 @@ ! 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 ; +io.styles io.streams.plain splitting +io.streams.duplex byte-arrays sequences.private ; 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: ( stream decoding -- newstream ) + +GENERIC: ( stream encoding -- newstream ) + +: replacement-char HEX: fffd ; ! Decoding + construct-empty ; +M: tuple f decoder construct-boa ; -: push-decoded ( buf ch -- buf ch state ) - over push 0 begin ; - -: push-replacement ( buf -- buf ch state ) - ! This is the replacement character - HEX: fffd push-decoded ; - -: space ( resizable -- room-left ) - dup underlying swap [ length ] 2apply - ; - -: full? ( resizable -- ? ) space zero? ; - -: end-read-loop ( buf ch state stream quot -- string/f ) - 2drop 2drop >string f like ; - -: 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 ; - -: decode-read ( length stream encoding -- string ) - rot -rot decode-read-loop ; - -TUPLE: decoder code cr ; -: ( stream encoding -- newstream ) - dup binary eq? [ drop ] [ - dupd init-decoder { set-delegate set-decoder-code } - decoder construct - ] if ; +: >decoder< ( decoder -- stream encoding ) + { decoder-stream decoder-code } get-slots ; : cr+ t swap set-decoder-cr ; inline @@ -82,72 +56,78 @@ TUPLE: decoder code cr ; over decoder-cr [ over cr- "\n" ?head [ - swap stream-read1 [ add ] when* - ] [ nip ] if - ] [ nip ] if ; + over stream-read1 [ add ] when* + ] when + ] when nip ; + +: read-loop ( n stream -- string ) + over 0 [ + [ + >r stream-read1 dup + [ swap r> set-nth-unsafe f ] [ r> 3drop t ] if + ] 2curry find-integer + ] keep swap [ head ] when* ; 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 keep-going? + 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? ] 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 ; +M: decoder dispose decoder-stream dispose ; + ! Encoding TUPLE: encode-error ; : encode-error ( -- * ) \ encode-error construct-empty throw ; -TUPLE: encoder code ; -: ( stream encoding -- newstream ) - dup binary eq? [ drop ] [ - construct-empty { set-delegate set-encoder-code } - encoder construct - ] if ; +TUPLE: encoder stream code ; +M: tuple-class construct-empty ; +M: tuple encoder construct-boa ; + +: >encoder< ( encoder -- stream encoding ) + { encoder-stream encoder-code } get-slots ; 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 ; INSTANCE: encoder plain-writer ! Rebinding duplex streams which have not read anything yet : reencode ( stream encoding -- newstream ) - over encoder? [ >r delegate r> ] when ; + over encoder? [ >r encoder-stream r> ] when ; : redecode ( stream encoding -- newstream ) - over decoder? [ >r delegate r> ] when ; + over decoder? [ >r decoder-stream r> ] when ; +PRIVATE> : ( stream-in stream-out encoding -- duplex ) tuck reencode >r redecode r> ; diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index 5887a8375e..02b10c45a5 100644 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -6,82 +6,68 @@ IN: io.encodings.utf8 ! Decoding UTF-8 -TUPLE: utf8 ch state ; +TUPLE: utf8 ; -SYMBOL: double -SYMBOL: triple -SYMBOL: triple2 -SYMBOL: quad -SYMBOL: quad2 -SYMBOL: quad3 +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? + [ 6 shift swap BIN: 111111 bitand bitor ] + [ 2drop replacement-char ] if ; -: begin-utf8 ( buf byte -- buf ch state ) +: double ( stream byte -- stream char ) + BIN: 11111 bitand append-nums ; + +: triple ( stream byte -- stream char ) + BIN: 1111 bitand append-nums append-nums ; + +: quad ( stream byte -- stream char ) + BIN: 111 bitand append-nums append-nums append-nums ; + +: begin-utf8 ( stream byte -- stream char ) { - { [ 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 ] } + { [ 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 ] } + { [ t ] [ drop replacement-char ] } } cond ; -: end-multibyte ( buf byte ch -- buf ch state ) - f append-nums [ push-decoded ] unless* ; +: decode-utf8 ( stream -- char/f ) + dup stream-read1 dup [ begin-utf8 ] when nip ; -: 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 ; - -: unpack-state ( encoding -- ch state ) - { utf8-ch utf8-state } get-slots ; - -: pack-state ( ch state encoding -- ) - { set-utf8-ch set-utf8-state } set-slots ; - -M: utf8 decode-step ( buf char encoding -- ) - [ unpack-state decode-utf8-step ] keep pack-state drop ; - -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> diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index 7833e0aa47..33404292a9 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -1,9 +1,9 @@ ! 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 ; diff --git a/extra/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor index bd71b733f1..16d87ef39c 100644 --- a/extra/io/encodings/ascii/ascii.factor +++ b/extra/io/encodings/ascii/ascii.factor @@ -1,18 +1,20 @@ ! 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 ; IN: io.encodings.ascii -: encode-check< ( string stream max -- ) - [ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ; + [ 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-character ] unless ; +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< ; diff --git a/extra/io/encodings/latin1/latin1.factor b/extra/io/encodings/latin1/latin1.factor index 71e98a1747..2b82318885 100755 --- a/extra/io/encodings/latin1/latin1.factor +++ b/extra/io/encodings/latin1/latin1.factor @@ -1,12 +1,12 @@ ! 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 ; +USING: io io.encodings kernel io.encodings.ascii.private ; IN: io.encodings.latin1 TUPLE: latin1 ; -M: latin1 stream-write-encoded - drop 256 encode-check< ; +M: latin1 encode-char + 256 encode-if< ; -M: latin1 decode-step - drop swap push ; +M: latin1 decode-char + drop stream-read1 ; diff --git a/extra/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor index a501fad0bd..7e82935db7 100755 --- a/extra/io/encodings/utf16/utf16.factor +++ b/extra/io/encodings/utf16/utf16.factor @@ -4,92 +4,71 @@ 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: utf16be ; 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 ; +TUPLE: utf16 started? ; -: 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 ; +r 2 shift r> BIN: 11 bitand bitor + over stream-read1 swap append-nums HEX: 10000 + + ] [ 2drop 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: 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 + ] [ swap append-nums ] 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 ; +: begin-utf16le ( stream byte -- stream char ) + over stream-read1 [ double-le ] [ drop replacement-char ] if* -: 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 ; +M: decode-char + drop dup stream-read1 dup [ begin-utf16le ] when nip ; ! UTF-16LE/BE encoding @@ -103,25 +82,25 @@ M: utf16le init-decoder nip begin over set-utf16le-state ; dup -8 shift BIN: 11011100 bitor swap BIN: 11111111 bitand ; -: char>utf16be ( char -- ) +: stream-write2 ( stream char1 char2 -- ) + rot [ stream-write1 ] 2apply ; + +: char>utf16be ( stream char -- ) dup HEX: FFFF > [ HEX: 10000 - - dup encode-first swap write1 write1 - encode-second swap write1 write1 - ] [ h>b/b write1 write1 ] if ; + dup encode-first stream-write2 + encode-second stream-write2 + ] [ h>b/b swap stream-write2 ] if ; -: stream-write-utf16be ( string stream -- ) - [ [ char>utf16be ] each ] with-stream* ; - -M: utf16be stream-write-encoded ( string stream encoding -- ) - drop stream-write-utf16be ; +M: utf16be encode-char ( char stream encoding -- ) + drop char>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 ; + dup encode-first swap stream-write2 + encode-second swap stream-write2 + ] [ h>b/b stream-write2 ] if ; : stream-write-utf16le ( string stream -- ) [ [ char>utf16le ] each ] with-stream* ; @@ -139,17 +118,15 @@ M: utf16le stream-write-encoded ( string stream encoding -- ) : 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 ; +M: utf16 ( stream utf16 -- decoder ) + 2 rot stream-read bom>le/be ; + +M: utf16 ( stream utf16 -- encoder ) + drop bom-le over stream-write utf16le ; + +PRIVATE> From 67c9e2f63192b8145a703bdf6d6dcc2d2e1079dd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 16 Mar 2008 15:17:11 -0500 Subject: [PATCH 017/886] make openbsd64 bootstrap fix target for openbsd64 --- misc/target | 6 ++++++ vm/os-openbsd-x86.64.h | 7 +++++-- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/misc/target b/misc/target index 0be7781301..c9f927a507 100755 --- a/misc/target +++ b/misc/target @@ -3,9 +3,15 @@ if [ \( `uname -s ` = FreeBSD \) -a \( `uname -p` = i386 \) ] then echo freebsd-x86-32 +elif [ \( `uname -s` = FreeBSD \) -a \( `uname -m` = amd64 \) ] +then + echo freebsd-x86-64 elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = i386 \) ] then echo openbsd-x86-32 +elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = amd64 \) ] +then + echo openbsd-x86-64 elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ] then echo macosx-ppc diff --git a/vm/os-openbsd-x86.64.h b/vm/os-openbsd-x86.64.h index ff225c3cd6..3386e80a4b 100644 --- a/vm/os-openbsd-x86.64.h +++ b/vm/os-openbsd-x86.64.h @@ -1,7 +1,10 @@ +#include + 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) From 6a8886b876246132db5723da955b56b57aeab059 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 16 Mar 2008 15:41:52 -0500 Subject: [PATCH 018/886] fix openbsd stat structure --- extra/unix/stat/openbsd/32/32.factor | 2 +- extra/unix/stat/openbsd/64/64.factor | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/unix/stat/openbsd/32/32.factor b/extra/unix/stat/openbsd/32/32.factor index 521735c9b4..61a37ba567 100644 --- a/extra/unix/stat/openbsd/32/32.factor +++ b/extra/unix/stat/openbsd/32/32.factor @@ -21,7 +21,7 @@ C-STRUCT: stat { "u_int32_t" "st_flags" } { "u_int32_t" "st_gen" } { "int32_t" "st_lspare1" } - { "timespec*" "st_birthtimespec" } + { "timespec*" "st_birthtim" } { "int64_t" "st_qspare1" } { "int64_t" "st_qspare2" } ; diff --git a/extra/unix/stat/openbsd/64/64.factor b/extra/unix/stat/openbsd/64/64.factor index 752574a43a..61a37ba567 100644 --- a/extra/unix/stat/openbsd/64/64.factor +++ b/extra/unix/stat/openbsd/64/64.factor @@ -12,16 +12,16 @@ C-STRUCT: stat { "gid_t" "st_gid" } { "dev_t" "st_rdev" } { "int32_t" "st_lspare0" } - { "timespec*" "st_atimespec" } - { "timespec*" "st_mtimespec" } - { "timespec*" "st_ctimespec" } + { "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_birthtimespec" } + { "timespec*" "st_birthtim" } { "int64_t" "st_qspare1" } { "int64_t" "st_qspare2" } ; From 906734e8eb0b155bdd5a8a74af8e3749e81f7761 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 16 Mar 2008 16:29:49 -0500 Subject: [PATCH 019/886] add unix types --- misc/grovel.c | 1 + 1 file changed, 1 insertion(+) diff --git a/misc/grovel.c b/misc/grovel.c index 4460c3aab3..1ac23a9631 100644 --- a/misc/grovel.c +++ b/misc/grovel.c @@ -133,6 +133,7 @@ int main() { #endif #ifdef UNIX + unix_types(); #endif return 0; From 5bd82ef42b1320001f18eab0f465c4dc5bd2f9e6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 16 Mar 2008 16:40:58 -0500 Subject: [PATCH 020/886] add long --- misc/grovel.c | 1 + 1 file changed, 1 insertion(+) diff --git a/misc/grovel.c b/misc/grovel.c index 1ac23a9631..2e39d2495e 100644 --- a/misc/grovel.c +++ b/misc/grovel.c @@ -136,5 +136,6 @@ int main() { unix_types(); #endif + grovel(long); return 0; } From 2cdc172f04eed9b5f4374033fa460fb98e30b737 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 16 Mar 2008 16:41:58 -0500 Subject: [PATCH 021/886] split types on openbsd --- extra/unix/types/openbsd/32/32.factor | 29 +++++++++++++++++++++ extra/unix/types/openbsd/64/64.factor | 29 +++++++++++++++++++++ extra/unix/types/openbsd/openbsd.factor | 34 +++++-------------------- 3 files changed, 64 insertions(+), 28 deletions(-) create mode 100755 extra/unix/types/openbsd/32/32.factor create mode 100755 extra/unix/types/openbsd/64/64.factor mode change 100755 => 100644 extra/unix/types/openbsd/openbsd.factor diff --git a/extra/unix/types/openbsd/32/32.factor b/extra/unix/types/openbsd/32/32.factor new file mode 100755 index 0000000000..221f9896b0 --- /dev/null +++ b/extra/unix/types/openbsd/32/32.factor @@ -0,0 +1,29 @@ +USING: alien.syntax ; +IN: unix.types + +! OpenBSD 4.2 + +TYPEDEF: ushort __uint16_t +TYPEDEF: uint __uint32_t +TYPEDEF: int __int32_t +TYPEDEF: longlong __int64_t + +TYPEDEF: int int32_t +TYPEDEF: int 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 ino_t +TYPEDEF: __uint16_t mode_t +TYPEDEF: __uint16_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 diff --git a/extra/unix/types/openbsd/64/64.factor b/extra/unix/types/openbsd/64/64.factor new file mode 100755 index 0000000000..b24cc94a90 --- /dev/null +++ b/extra/unix/types/openbsd/64/64.factor @@ -0,0 +1,29 @@ +USING: alien.syntax ; +IN: unix.types + +! OpenBSD 4.2 + +TYPEDEF: ushort __uint16_t +TYPEDEF: uint __uint32_t +TYPEDEF: int __int32_t +TYPEDEF: longlong __int64_t + +TYPEDEF: int int32_t +TYPEDEF: int 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 ino_t +TYPEDEF: __uint32_t mode_t +TYPEDEF: __uint32_t nlink_t +TYPEDEF: __uint32_t uid_t +TYPEDEF: __uint32_t gid_t +TYPEDEF: __uint64_t off_t +TYPEDEF: __uint64_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 diff --git a/extra/unix/types/openbsd/openbsd.factor b/extra/unix/types/openbsd/openbsd.factor old mode 100755 new mode 100644 index 221f9896b0..9d2508e91c --- a/extra/unix/types/openbsd/openbsd.factor +++ b/extra/unix/types/openbsd/openbsd.factor @@ -1,29 +1,7 @@ -USING: alien.syntax ; -IN: unix.types +USING: layouts combinators vocabs.loader ; +IN: unix.stat -! OpenBSD 4.2 - -TYPEDEF: ushort __uint16_t -TYPEDEF: uint __uint32_t -TYPEDEF: int __int32_t -TYPEDEF: longlong __int64_t - -TYPEDEF: int int32_t -TYPEDEF: int 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 ino_t -TYPEDEF: __uint16_t mode_t -TYPEDEF: __uint16_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 +cell-bits { + { 32 [ "unix.types.openbsd.32" require ] } + { 64 [ "unix.types.openbsd.64" require ] } +} case From bdda6fc3cbfb4e676d510de75e8ab41cb4c39d2a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 12:10:43 -0500 Subject: [PATCH 022/886] make openbsd compile with NO_UI=1 --- vm/Config.openbsd | 1 + vm/os-openbsd-x86.32.h | 7 +++++-- vm/os-openbsd.h | 4 ++++ 3 files changed, 10 insertions(+), 2 deletions(-) diff --git a/vm/Config.openbsd b/vm/Config.openbsd index 61534d4e66..8724ebf378 100644 --- a/vm/Config.openbsd +++ b/vm/Config.openbsd @@ -1,4 +1,5 @@ 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) diff --git a/vm/os-openbsd-x86.32.h b/vm/os-openbsd-x86.32.h index 7e1e4894c2..0617e62c0d 100644 --- a/vm/os-openbsd-x86.32.h +++ b/vm/os-openbsd-x86.32.h @@ -1,7 +1,10 @@ +#include + 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) diff --git a/vm/os-openbsd.h b/vm/os-openbsd.h index af47f7bcea..21e34c98f8 100644 --- a/vm/os-openbsd.h +++ b/vm/os-openbsd.h @@ -1,2 +1,6 @@ #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 From d82808b3a0f35b7f0b9fc9b397e875023ca8bb71 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 14:53:01 -0500 Subject: [PATCH 023/886] add freebsd 64, untested add openbsd 32/64, untested --- extra/unix/stat/freebsd/32/32.factor | 30 ++++++++++++++++++++++ extra/unix/stat/freebsd/64/64.factor | 30 ++++++++++++++++++++++ extra/unix/stat/freebsd/freebsd.factor | 33 ++++--------------------- extra/unix/stat/openbsd/32/32.factor | 29 ++++++++++++++++++++++ extra/unix/stat/openbsd/64/64.factor | 29 ++++++++++++++++++++++ extra/unix/stat/openbsd/openbsd.factor | 7 ++++++ extra/unix/types/openbsd/openbsd.factor | 29 ++++++++++++++++++++++ extra/unix/types/types.factor | 4 ++- 8 files changed, 162 insertions(+), 29 deletions(-) create mode 100644 extra/unix/stat/freebsd/32/32.factor create mode 100644 extra/unix/stat/freebsd/64/64.factor create mode 100644 extra/unix/stat/openbsd/32/32.factor create mode 100644 extra/unix/stat/openbsd/64/64.factor create mode 100644 extra/unix/stat/openbsd/openbsd.factor create mode 100755 extra/unix/types/openbsd/openbsd.factor diff --git a/extra/unix/stat/freebsd/32/32.factor b/extra/unix/stat/freebsd/32/32.factor new file mode 100644 index 0000000000..a81fc4f02e --- /dev/null +++ b/extra/unix/stat/freebsd/32/32.factor @@ -0,0 +1,30 @@ +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 diff --git a/extra/unix/stat/freebsd/64/64.factor b/extra/unix/stat/freebsd/64/64.factor new file mode 100644 index 0000000000..75d51cd6ae --- /dev/null +++ b/extra/unix/stat/freebsd/64/64.factor @@ -0,0 +1,30 @@ +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 ) ; diff --git a/extra/unix/stat/freebsd/freebsd.factor b/extra/unix/stat/freebsd/freebsd.factor index a81fc4f02e..299d0ecab5 100644 --- a/extra/unix/stat/freebsd/freebsd.factor +++ b/extra/unix/stat/freebsd/freebsd.factor @@ -1,30 +1,7 @@ -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 diff --git a/extra/unix/stat/openbsd/32/32.factor b/extra/unix/stat/openbsd/32/32.factor new file mode 100644 index 0000000000..e4357ba70b --- /dev/null +++ b/extra/unix/stat/openbsd/32/32.factor @@ -0,0 +1,29 @@ +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_atimespec" } + { "timespec*" "st_mtimespec" } + { "timespec*" "st_ctimespec" } + { "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_birthtimespec" } + { "int64_t" "st_qspare1" } + { "int64_t" "st_qspare2" } ; + +! FUNCTION: int stat ( char* pathname, stat* buf ) ; +FUNCTION: int lstat ( char* pathname, stat* buf ) ; diff --git a/extra/unix/stat/openbsd/64/64.factor b/extra/unix/stat/openbsd/64/64.factor new file mode 100644 index 0000000000..e4357ba70b --- /dev/null +++ b/extra/unix/stat/openbsd/64/64.factor @@ -0,0 +1,29 @@ +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_atimespec" } + { "timespec*" "st_mtimespec" } + { "timespec*" "st_ctimespec" } + { "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_birthtimespec" } + { "int64_t" "st_qspare1" } + { "int64_t" "st_qspare2" } ; + +! FUNCTION: int stat ( char* pathname, stat* buf ) ; +FUNCTION: int lstat ( char* pathname, stat* buf ) ; diff --git a/extra/unix/stat/openbsd/openbsd.factor b/extra/unix/stat/openbsd/openbsd.factor new file mode 100644 index 0000000000..0a2312302b --- /dev/null +++ b/extra/unix/stat/openbsd/openbsd.factor @@ -0,0 +1,7 @@ +USING: layouts combinators vocabs.loader ; +IN: unix.stat + +cell-bits { + { 32 [ "unix.stat.openbsd.32" require ] } + { 64 [ "unix.stat.openbsd.64" require ] } +} case diff --git a/extra/unix/types/openbsd/openbsd.factor b/extra/unix/types/openbsd/openbsd.factor new file mode 100755 index 0000000000..221f9896b0 --- /dev/null +++ b/extra/unix/types/openbsd/openbsd.factor @@ -0,0 +1,29 @@ +USING: alien.syntax ; +IN: unix.types + +! OpenBSD 4.2 + +TYPEDEF: ushort __uint16_t +TYPEDEF: uint __uint32_t +TYPEDEF: int __int32_t +TYPEDEF: longlong __int64_t + +TYPEDEF: int int32_t +TYPEDEF: int 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 ino_t +TYPEDEF: __uint16_t mode_t +TYPEDEF: __uint16_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 diff --git a/extra/unix/types/types.factor b/extra/unix/types/types.factor index f046197d30..59d0c05a87 100644 --- a/extra/unix/types/types.factor +++ b/extra/unix/types/types.factor @@ -10,6 +10,8 @@ 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 ] } [ drop ] } -case \ No newline at end of file +case From 6d36f738eb94a648fd8841c9288fd9f5c329a3c6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 14:54:16 -0500 Subject: [PATCH 024/886] playing around with a cross-platform c program to write out factor structs --- misc/grovel.c | 139 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 139 insertions(+) create mode 100644 misc/grovel.c diff --git a/misc/grovel.c b/misc/grovel.c new file mode 100644 index 0000000000..4460c3aab3 --- /dev/null +++ b/misc/grovel.c @@ -0,0 +1,139 @@ +#include + +#if defined(__FreeBSD__) + #define BSD + #define FREEBSD + #define UNIX +#endif + +#if defined(__NetBSD__) + #define BSD + #define NETBSD + #define UNIX +#endif + +#if (__OpenBSD__) + #define BSD + #define OPENBSD + #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 + #include +#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)); + +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_atimespec"); + grovel2(struct timespec, "st_mtimespec"); + grovel2(struct timespec, "st_ctimespec"); + 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); +} + +int main() { + //grovel(char); + //grovel(int); + //grovel(uint); + //grovel(long); + //grovel(ulong); + //grovel(long long); + //grovel(unsigned long long); + //grovel(void*); + //grovel(char*); + +#ifdef FREEBSD + grovel(blkcnt_t); + grovel(blksize_t); + grovel(fflags_t); +#endif + +#ifdef OPENBSD + openbsd_stat(); + openbsd_types(); +#endif + +#ifdef UNIX +#endif + + return 0; +} From 936bd26a3aefe824a52dd7d182b7e7bc4c1b6f9b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 15:00:49 -0500 Subject: [PATCH 025/886] update core/ to use ERROR: --- core/alien/alien.factor | 12 ++++++------ core/alien/c-types/c-types.factor | 4 +--- core/combinators/combinators.factor | 8 ++------ core/debugger/debugger.factor | 18 +++++------------- core/definitions/definitions.factor | 5 +---- core/generic/math/math.factor | 5 +---- core/generic/standard/standard.factor | 5 +---- core/inference/inference-tests.factor | 4 ++-- core/inference/transforms/transforms.factor | 5 +---- core/io/encodings/encodings.factor | 8 ++------ core/io/files/files.factor | 5 +---- core/io/streams/duplex/duplex.factor | 5 ++--- core/libc/libc.factor | 14 ++++---------- core/parser/parser.factor | 19 ++++--------------- core/sequences/sequences.factor | 12 +++--------- core/syntax/syntax.factor | 1 + core/tuples/tuples.factor | 4 ++-- core/vocabs/vocabs.factor | 7 ++----- core/words/words.factor | 11 ++++------- 19 files changed, 45 insertions(+), 107 deletions(-) diff --git a/core/alien/alien.factor b/core/alien/alien.factor index fc89586b68..0afff0c497 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -65,21 +65,21 @@ TUPLE: library path abi dll ; 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 ; + alien-indirect-error ; TUPLE: alien-invoke library function return parameters ; -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 ; diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index f1d8abdc1e..d874243d71 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -26,9 +26,7 @@ global [ 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 [ diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 53d18b53ca..807b372e1d 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -5,16 +5,12 @@ USING: arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors hashtables sorting ; -TUPLE: no-cond ; - -: no-cond ( -- * ) \ no-cond construct-empty throw ; +ERROR: no-cond ; : cond ( assoc -- ) [ first call ] find nip dup [ second call ] [ no-cond ] if ; -TUPLE: no-case ; - -: no-case ( -- * ) \ no-case construct-empty throw ; +ERROR: no-case ; : case ( obj assoc -- ) [ dup array? [ dupd first = ] [ quotation? ] if ] find nip diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index ad2fa14954..40bc6615fa 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -75,9 +75,7 @@ SYMBOL: error-hook : 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 ; @@ -86,28 +84,22 @@ TUPLE: assert got expect ; : trim-datastacks ( seq1 seq2 -- seq1' seq2' ) 2dup [ length ] 2apply min tuck tail >r tail r> ; -TUPLE: relative-underflow stack ; - -: 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 -- ) diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 01f9643cdd..cec5109909 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -3,10 +3,7 @@ IN: definitions USING: kernel sequences namespaces assocs graphs ; -TUPLE: no-compilation-unit definition ; - -: no-compilation-unit ( definition -- * ) - \ no-compilation-unit construct-boa throw ; +ERROR: no-compilation-unit definition ; GENERIC: where ( defspec -- loc ) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index b01fb87f72..46f57a1629 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -33,10 +33,7 @@ PREDICATE: class math-class ( object -- ? ) 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 ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 35161319ef..37f72e7d95 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -26,10 +26,7 @@ SYMBOL: (dispatch#) : 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 ) picker swap [ no-method ] curry append ; diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 3c12e388c4..4f5d199264 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -514,10 +514,10 @@ DEFER: an-inline-word { 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 diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 240f39218b..a829bad47e 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -64,14 +64,11 @@ M: pair (bitfield-quot) ( spec -- quot ) \ 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? [ [get-slots] ] [ duplicated-slots-error ] if diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 03ea2262a8..610d294bb6 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -18,17 +18,13 @@ GENERIC: ( stream decoding -- newstream ) TUPLE: decoder stream code cr ; -TUPLE: decode-error ; - -: decode-error ( -- * ) \ decode-error construct-empty throw ; +ERROR: decode-error ; GENERIC: ( stream encoding -- newstream ) TUPLE: encoder stream code ; -TUPLE: encode-error ; - -: encode-error ( -- * ) \ encode-error construct-empty throw ; +ERROR: encode-error ; ! Decoding diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 3de7559303..f9116895e4 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -48,10 +48,7 @@ M: object root-directory? ( path -- ? ) path-separator? ; : special-directory? ( name -- ? ) { "." ".." } member? ; -TUPLE: no-parent-directory path ; - -: no-parent-directory ( path -- * ) - \ no-parent-directory construct-boa throw ; +ERROR: no-parent-directory path ; : parent-directory ( path -- parent ) right-trim-separators { diff --git a/core/io/streams/duplex/duplex.factor b/core/io/streams/duplex/duplex.factor index 97e60b4a60..83e991b713 100755 --- a/core/io/streams/duplex/duplex.factor +++ b/core/io/streams/duplex/duplex.factor @@ -11,11 +11,10 @@ TUPLE: duplex-stream in out closed? ; : ( in out -- stream ) f duplex-stream construct-boa ; -TUPLE: check-closed ; +ERROR: stream-closed-twice ; : check-closed ( stream -- ) - duplex-stream-closed? - [ \ check-closed construct-boa throw ] when ; + duplex-stream-closed? [ stream-closed-twice ] when ; : duplex-stream-in+ ( duplex -- stream ) dup check-closed duplex-stream-in ; diff --git a/core/libc/libc.factor b/core/libc/libc.factor index e82b244d6d..756d29e551 100755 --- a/core/libc/libc.factor +++ b/core/libc/libc.factor @@ -23,20 +23,14 @@ SYMBOL: mallocs 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 ; [ bad-number ] unless* parsed ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 3c69bfa41c..14674ba2f2 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -41,19 +41,14 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; : 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 ; @@ -190,8 +185,7 @@ TUPLE: slice from to seq ; : 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 diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 8cc9211599..843f372542 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -165,6 +165,7 @@ IN: bootstrap.syntax "ERROR:" [ CREATE-CLASS dup ";" parse-tokens define-tuple-class + dup save-location dup [ construct-boa throw ] curry define ] define-syntax diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index e48a803659..6f94d034fa 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -87,11 +87,11 @@ PRIVATE> 2dup delegate-slot-spec add* "slots" set-word-prop define-slots ; -TUPLE: check-tuple class ; +ERROR: no-tuple-class class ; : check-tuple ( class -- ) dup tuple-class? - [ drop ] [ \ check-tuple construct-boa throw ] if ; + [ drop ] [ no-tuple-class ] if ; : define-tuple-class ( class slots -- ) 2dup check-shape diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 807e08f73b..9cf5a39772 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -60,16 +60,13 @@ M: f vocab-help ; : create-vocab ( name -- vocab ) dictionary get [ ] 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 vocab [ ] [ vocab-name no-vocab ] ?if ; : vocabs ( -- seq ) dictionary get keys natural-sort ; diff --git a/core/words/words.factor b/core/words/words.factor index a36cca00ac..de253e6fee 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -21,9 +21,7 @@ M: word definer drop \ : \ ; ; M: word definition word-def ; -TUPLE: undefined ; - -: undefined ( -- * ) \ undefined construct-empty throw ; +ERROR: undefined ; PREDICATE: word deferred ( obj -- ? ) word-def [ undefined ] = ; @@ -189,12 +187,11 @@ M: word subwords drop f ; [ ] [ 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 From 87b13afb9b10f0f27687cf3c5346a4a33685c2f3 Mon Sep 17 00:00:00 2001 From: sheeple Date: Thu, 20 Mar 2008 15:06:22 -0500 Subject: [PATCH 026/886] change old mt to random-generator for deploy --- extra/tools/deploy/shaker/shaker.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 44fb15ac7e..d31a3460ca 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -19,7 +19,7 @@ QUALIFIED: libc.private QUALIFIED: libc.private QUALIFIED: listener QUALIFIED: prettyprint.config -QUALIFIED: random.private +QUALIFIED: random QUALIFIED: source-files QUALIFIED: threads QUALIFIED: vocabs @@ -108,7 +108,7 @@ IN: tools.deploy.shaker : stripped-globals ( -- seq ) [ - random.private:mt , + random:random-generator , { bootstrap.stage2:bootstrap-time From e5392461315b7ca216627b5336c2f33b33119f28 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 15:11:27 -0500 Subject: [PATCH 027/886] fix stat on openbsd32 --- extra/unix/stat/openbsd/32/32.factor | 8 ++++---- extra/unix/stat/openbsd/64/64.factor | 2 +- extra/unix/stat/stat.factor | 3 ++- extra/unix/types/types.factor | 1 - 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/unix/stat/openbsd/32/32.factor b/extra/unix/stat/openbsd/32/32.factor index e4357ba70b..521735c9b4 100644 --- a/extra/unix/stat/openbsd/32/32.factor +++ b/extra/unix/stat/openbsd/32/32.factor @@ -12,9 +12,9 @@ C-STRUCT: stat { "gid_t" "st_gid" } { "dev_t" "st_rdev" } { "int32_t" "st_lspare0" } - { "timespec*" "st_atimespec" } - { "timespec*" "st_mtimespec" } - { "timespec*" "st_ctimespec" } + { "timespec*" "st_atim" } + { "timespec*" "st_mtim" } + { "timespec*" "st_ctim" } { "off_t" "st_size" } { "int64_t" "st_blocks" } { "u_int32_t" "st_blksize" } @@ -25,5 +25,5 @@ C-STRUCT: stat { "int64_t" "st_qspare1" } { "int64_t" "st_qspare2" } ; -! FUNCTION: int stat ( char* pathname, stat* buf ) ; +FUNCTION: int stat ( char* pathname, stat* buf ) ; FUNCTION: int lstat ( char* pathname, stat* buf ) ; diff --git a/extra/unix/stat/openbsd/64/64.factor b/extra/unix/stat/openbsd/64/64.factor index e4357ba70b..752574a43a 100644 --- a/extra/unix/stat/openbsd/64/64.factor +++ b/extra/unix/stat/openbsd/64/64.factor @@ -25,5 +25,5 @@ C-STRUCT: stat { "int64_t" "st_qspare1" } { "int64_t" "st_qspare2" } ; -! FUNCTION: int stat ( char* pathname, stat* buf ) ; +FUNCTION: int stat ( char* pathname, stat* buf ) ; FUNCTION: int lstat ( char* pathname, stat* buf ) ; diff --git a/extra/unix/stat/stat.factor b/extra/unix/stat/stat.factor index e0a6a9fb76..f7432332b9 100644 --- a/extra/unix/stat/stat.factor +++ b/extra/unix/stat/stat.factor @@ -63,7 +63,8 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ; { "linux" [ "unix.stat.linux" require ] } { "macosx" [ "unix.stat.macosx" require ] } { "freebsd" [ "unix.stat.freebsd" require ] } - [ drop ] + { "netbsd" [ "unix.stat.netbsd" require ] } + { "openbsd" [ "unix.stat.openbsd" require ] } } case >> diff --git a/extra/unix/types/types.factor b/extra/unix/types/types.factor index 59d0c05a87..ed2dbd5ba8 100644 --- a/extra/unix/types/types.factor +++ b/extra/unix/types/types.factor @@ -12,6 +12,5 @@ os { "freebsd" [ "unix.types.freebsd" require ] } { "openbsd" [ "unix.types.openbsd" require ] } { "netbsd" [ "unix.types.netbsd" require ] } - [ drop ] } case From c996c092fc4c03067a0695f1eee1a59798094746 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 15:24:30 -0500 Subject: [PATCH 028/886] start a unit test file for stat --- extra/unix/stat/stat-tests.factor | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 extra/unix/stat/stat-tests.factor diff --git a/extra/unix/stat/stat-tests.factor b/extra/unix/stat/stat-tests.factor new file mode 100644 index 0000000000..02ae29ae5a --- /dev/null +++ b/extra/unix/stat/stat-tests.factor @@ -0,0 +1,8 @@ +USING: kernel tools.test files.unique ; +IN: unix.stat.tests + +[ 123 ] [ + 123 CHAR: a [ + write + ] with-unique-file file-size>> +] unit-test From 2f93c77e7c20a35d45a37549d0672036f775993c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 15:35:35 -0500 Subject: [PATCH 029/886] add -lz --- vm/Config.openbsd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/Config.openbsd b/vm/Config.openbsd index 8724ebf378..240adf8087 100644 --- a/vm/Config.openbsd +++ b/vm/Config.openbsd @@ -2,4 +2,4 @@ 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 From bf57d5d5aaf496aa88372f4c66ad0df78916a3ac Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 15:35:59 -0500 Subject: [PATCH 030/886] add openbsd to target --- misc/target | 3 +++ 1 file changed, 3 insertions(+) diff --git a/misc/target b/misc/target index 880de8f47a..0be7781301 100755 --- a/misc/target +++ b/misc/target @@ -3,6 +3,9 @@ if [ \( `uname -s ` = FreeBSD \) -a \( `uname -p` = i386 \) ] then echo freebsd-x86-32 +elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = i386 \) ] +then + echo openbsd-x86-32 elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ] then echo macosx-ppc From b42f9605efdd09ff798fb8eed7662714a354e16f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 15:47:16 -0500 Subject: [PATCH 031/886] fix summary for new ERROR: words --- core/debugger/debugger.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 00787f9da2..4775093ba7 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -202,13 +202,13 @@ M: no-method error. M: no-math-method summary drop "No suitable arithmetic method" ; -M: check-closed summary +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 +M: no-tuple-class summary drop "Invalid class for define-constructor" ; M: no-cond summary @@ -246,7 +246,7 @@ M: no-compilation-unit error. 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 From a556cdbed149bcbca958df7542f0ec9ef1bcfe59 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 15:47:24 -0500 Subject: [PATCH 032/886] document ERROR: --- core/syntax/syntax-docs.factor | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index dc06a239de..ebdd95ae14 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -560,6 +560,13 @@ HELP: TUPLE: $nl "Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ; +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. Defines a new word " { $snippet "class?" } " that boa-constructs this tuple and throws it." } ; + +{ POSTPONE: ERROR: POSTPONE: TUPLE: } related-words + HELP: C: { $syntax "C: constructor class" } { $values { "constructor" "a new word to define" } { "class" tuple-class } } From 5b507693b953781e21911e63bdd66dcbfdc43fab Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 16:01:34 -0500 Subject: [PATCH 033/886] fix tuples unit test --- core/tuples/tuples-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index 63bb233654..b5076ea22b 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -236,7 +236,7 @@ C: erg's-reshape-problem [ "IN: tuples.tests SYMBOL: not-a-class C: not-a-class" eval -] [ [ check-tuple? ] is? ] must-fail-with +] [ [ no-tuple-class? ] is? ] must-fail-with ! Hardcore unit tests USE: threads From 44b1783333273f1902cfc2aafe82c9c6dc560199 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 16:50:02 -0500 Subject: [PATCH 034/886] Remove extra/new-slots; its in the core now --- extra/new-slots/authors.txt | 1 - extra/new-slots/new-slots.factor | 67 -------------------------------- 2 files changed, 68 deletions(-) delete mode 100755 extra/new-slots/authors.txt delete mode 100755 extra/new-slots/new-slots.factor diff --git a/extra/new-slots/authors.txt b/extra/new-slots/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/new-slots/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/new-slots/new-slots.factor b/extra/new-slots/new-slots.factor deleted file mode 100755 index 9773da7b41..0000000000 --- a/extra/new-slots/new-slots.factor +++ /dev/null @@ -1,67 +0,0 @@ -! 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 ) - ">>" 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-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 >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 From c1afb4b093636581f7ea74197ee12cb3e87c54e2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 16:52:22 -0500 Subject: [PATCH 035/886] remove stat tests overhaul unique files --- extra/io/files/unique/backend/backend.factor | 2 +- extra/io/files/unique/unique-docs.factor | 32 ++++++-------------- extra/io/files/unique/unique.factor | 20 +++++------- extra/io/unix/files/unique/unique.factor | 5 ++- extra/io/windows/files/unique/unique.factor | 5 +-- extra/unix/stat/stat-tests.factor | 8 ----- 6 files changed, 22 insertions(+), 50 deletions(-) delete mode 100644 extra/unix/stat/stat-tests.factor diff --git a/extra/io/files/unique/backend/backend.factor b/extra/io/files/unique/backend/backend.factor index b26557688b..7b9809fa28 100644 --- a/extra/io/files/unique/backend/backend.factor +++ b/extra/io/files/unique/backend/backend.factor @@ -1,5 +1,5 @@ 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 ) diff --git a/extra/io/files/unique/unique-docs.factor b/extra/io/files/unique/unique-docs.factor index 61f960d9f7..fcfcc15678 100644 --- a/extra/io/files/unique/unique-docs.factor +++ b/extra/io/files/unique/unique-docs.factor @@ -6,18 +6,16 @@ ARTICLE: "unique" "Making and using unique files" "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 ) { $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 } " 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 } ; @@ -27,24 +25,12 @@ HELP: make-unique-directory ( -- path ) { $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 -- ) +HELP: with-unique-file ( prefix suffix 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 } ; +{ $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." } ; diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor index 9a271e402c..a180a28f23 100644 --- a/extra/io/files/unique/unique.factor +++ b/extra/io/files/unique/unique.factor @@ -2,8 +2,8 @@ ! 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 -: make-unique-file ( prefix suffix -- path stream ) +: make-unique-file ( prefix suffix -- path ) temporary-path -rot [ 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 ) [ @@ -40,12 +37,9 @@ PRIVATE> 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" ] } diff --git a/extra/io/unix/files/unique/unique.factor b/extra/io/unix/files/unique/unique.factor index 185d9cd405..c5365d8d5c 100644 --- a/extra/io/unix/files/unique/unique.factor +++ b/extra/io/unix/files/unique/unique.factor @@ -5,8 +5,7 @@ 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 - ; +M: unix-io (make-unique-file) ( path -- ) + open-unique-flags file-mode open dup io-error close ; M: unix-io temporary-path ( -- path ) "/tmp" ; diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor index 0823c3f0f3..112dea48a7 100644 --- a/extra/io/windows/files/unique/unique.factor +++ b/extra/io/windows/files/unique/unique.factor @@ -2,8 +2,9 @@ USING: kernel system io.files.unique.backend windows.kernel32 io.windows io.nonblocking ; IN: io.windows.files.unique -M: windows-io (make-unique-file) ( path -- stream ) - GENERIC_WRITE CREATE_NEW 0 open-file 0 ; +M: windows-io (make-unique-file) ( path -- ) + GENERIC_WRITE CREATE_NEW 0 open-file + CloseHandle win32-error=0/f ; M: windows-io temporary-path ( -- path ) "TEMP" os-env ; diff --git a/extra/unix/stat/stat-tests.factor b/extra/unix/stat/stat-tests.factor deleted file mode 100644 index 02ae29ae5a..0000000000 --- a/extra/unix/stat/stat-tests.factor +++ /dev/null @@ -1,8 +0,0 @@ -USING: kernel tools.test files.unique ; -IN: unix.stat.tests - -[ 123 ] [ - 123 CHAR: a [ - write - ] with-unique-file file-size>> -] unit-test From a6e1d83740cae9cf855d3c5dfca4ce01e07889ac Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 17:20:03 -0500 Subject: [PATCH 036/886] add calloc to core/bootstrap/compiler --- core/bootstrap/compiler/compiler.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 5ccde88e28..04d57dff16 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -79,7 +79,7 @@ nl "." write flush { - malloc free memcpy + malloc calloc free memcpy } compile " done" print flush From ca32657972bc2e77b63d18d21a5bf4fad1b5e83f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 17:25:50 -0500 Subject: [PATCH 037/886] Documentation updates --- core/mirrors/mirrors-docs.factor | 9 ++- core/slots/slots-docs.factor | 75 ++++++++++++++++++++-- core/syntax/syntax-docs.factor | 2 +- core/tuples/tuples-docs.factor | 107 ++++++++++++++++++++++++------- 4 files changed, 160 insertions(+), 33 deletions(-) diff --git a/core/mirrors/mirrors-docs.factor b/core/mirrors/mirrors-docs.factor index 140f92567b..29ed153a2e 100755 --- a/core/mirrors/mirrors-docs.factor +++ b/core/mirrors/mirrors-docs.factor @@ -2,14 +2,17 @@ USING: help.markup help.syntax slots kernel assocs sequences ; 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 } -"A view of a sequence as an associative structure:" +"An enum provides such a view of a sequence:" { $subsection enum } { $subsection } "Utility word used by developer tools which inspect objects:" -{ $subsection make-mirror } ; +{ $subsection make-mirror } +{ $see-also "slots" } ; ABOUT: "mirrors" diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 8a1fb16fa9..55cff63963 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -4,21 +4,86 @@ effects generic.standard tuples 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 + "" + " \"Happy birthday\" >>subject" + " { \"bob@bigcorp.com\" } >>to" + " \"alice@bigcorp.com\" >>from" + "send-email" +} +"The following uses writers, and requires some stack shuffling:" +{ $code + "" + " \"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 + "" + " swap >>subject" + " swap >>to" + " \"alice@bigcorp.com\" >>from" + "send-email" +} +"This is because " { $link swap } " is easier to understand than " { $link tuck } ":" +{ $code + "" + " 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." +"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 } -"Slot methods type check, then call unsafe primitives:" -{ $subsection slot } -{ $subsection set-slot } ; +"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" diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index dc06a239de..ffb0d883eb 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -556,7 +556,7 @@ HELP: PREDICATE: HELP: TUPLE: { $syntax "TUPLE: class 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?" } "." +{ $description "Defines a new tuple class." $nl "Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ; diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor index 3af7d27d86..09d93884ad 100755 --- a/core/tuples/tuples-docs.factor +++ b/core/tuples/tuples-docs.factor @@ -3,11 +3,10 @@ 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:" +ARTICLE: "tuple-constructors" "Constructors" +"Tuples are created by calling one of two 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 "" } "." $nl "A shortcut for defining BOA constructors:" @@ -19,18 +18,13 @@ $nl "C: rgba" ": color construct-boa ; ! identical to above" "" - ": " - " { set-color-red set-color-green set-color-blue }" - " color construct ;" - ": f ; ! identical to above" + ": f ;" "" ": construct-empty ;" - ": { } color construct ; ! identical to above" ": f f f f ; ! 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" +ARTICLE: "tuple-delegation" "Tuple 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 } @@ -48,7 +42,7 @@ $nl "{ 0 0 } 10 \"my-ellipse\" set" "{ 1 0 0 } \"my-shape\" set" "\"my-ellipse\" get \"my-shape\" get set-delegate" - "\"my-shape\" get dup colored-color swap ellipse-center .s" + "\"my-shape\" get dup color>> swap center>> .s" "{ 0 0 }\n{ 1 0 0 }" } ; @@ -58,25 +52,90 @@ ARTICLE: "tuple-introspection" "Tuple introspection" { $subsection tuple>array } { $subsection tuple-slots } "Tuple classes can also be defined at run time:" -{ $subsection define-tuple-class } ; +{ $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 construct-empty ;" } +"Or we may wish the default constructor to always give employees a starting salary:" +{ $code + ": ( -- employee )" + " employee construct-empty" + " 40000 >>salary ;" +} +"We can define more refined constructors:" +{ $code + ": ( -- manager )" + " \"project manager\" >>position ;" } +"An alternative strategy is to define the most general BOA constructor first:" +{ $code + ": ( name position -- person )" + " 40000 employee construct-boa ;" +} +"Now we can define more specific constructors:" +{ $code + ": ( name -- person )" + " \"manager\" ;" } +"An example using reader words:" +{ $code + "TUPLE: check to amount number ;" + "" + "SYMBOL: checks" + "" + ": ( to amount -- check )" + " checks counter check construct-boa ;" + "" + ": biweekly-paycheck ( employee -- check )" + " dup name>> swap salary>> 26 / ;" +} +"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 ;" +} ; ARTICLE: "tuples" "Tuples" -"Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:" +"Tuples are user-defined classes composed of named slots." +{ $subsection "tuple-examples" } +"A parsing word defines tuple classes:" { $subsection POSTPONE: TUPLE: } -"An example:" -{ $code "TUPLE: person name address phone ;" "C: person" } -"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "" } ", 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" } } -} +"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" } "Further topics:" { $subsection "tuple-delegation" } -{ $subsection "tuple-introspection" } ; +{ $subsection "tuple-introspection" } +"Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ; ABOUT: "tuples" From 0565bbe0bcd6a0d43588b8a15cbc3e2f73a59e72 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 17:25:54 -0500 Subject: [PATCH 038/886] Fix bug --- extra/tools/vocabs/vocabs.factor | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 44a64cc9dd..b086b30a5e 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -34,8 +34,13 @@ IN: tools.vocabs : source-modified? ( path -- ? ) dup source-files get at [ - dup source-file-path ?resource-path utf8 file-lines lines-crc32 - swap source-file-checksum = not + dup source-file-path ?resource-path + dup exists? [ + utf8 file-lines lines-crc32 + swap source-file-checksum = not + ] [ + 2drop f + ] if ] [ resource-exists? ] ?if ; From 6d434090e0c3fe7fd778e628442f8c0021093400 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 17:38:39 -0500 Subject: [PATCH 039/886] Fixes --- core/io/io-tests.factor | 18 +++++++++--------- extra/help/lint/lint.factor | 2 -- extra/help/markup/markup-tests.factor | 12 ------------ 3 files changed, 9 insertions(+), 23 deletions(-) diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 22c942d2d9..8a9089a564 100755 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -28,15 +28,6 @@ IN: io.tests ! Make sure we use correct to_c_string form when writing [ ] [ "\0" write ] unit-test -[ "" ] [ 0 read ] unit-test - -! [ ] [ "123" write 9000 CHAR: x write flush ] unit-test - -[ - "/core/io/test/binary.txt" - [ 0.2 read ] with-stream -] must-fail - [ { { "It seems " CHAR: J } @@ -58,3 +49,12 @@ IN: io.tests 10 [ 65536 read drop ] times ] with-file-reader ] unit-test + +! [ "" ] [ 0 read ] unit-test + +! [ ] [ "123" write 9000 CHAR: x write flush ] unit-test + +! [ +! "/core/io/test/binary.txt" +! [ 0.2 read ] with-stream +! ] must-fail diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index d8a4f83169..b65e44fda4 100755 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -39,8 +39,6 @@ IN: help.lint { $shuffle $values-x/y - $slot-reader - $slot-writer $predicate $class-description $error-description diff --git a/extra/help/markup/markup-tests.factor b/extra/help/markup/markup-tests.factor index 0b4b69bf59..6b138a18ab 100644 --- a/extra/help/markup/markup-tests.factor +++ b/extra/help/markup/markup-tests.factor @@ -4,18 +4,6 @@ IN: help.markup.tests 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 From 010856c8707998ff187ba5db700552d01d7d00c7 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 20 Mar 2008 17:33:01 -0600 Subject: [PATCH 040/886] Add help for math.ranges --- extra/math/ranges/ranges-docs.factor | 21 +++++++++++++++++++++ extra/math/ranges/ranges.factor | 16 ++++++++-------- 2 files changed, 29 insertions(+), 8 deletions(-) create mode 100644 extra/math/ranges/ranges-docs.factor diff --git a/extra/math/ranges/ranges-docs.factor b/extra/math/ranges/ranges-docs.factor new file mode 100644 index 0000000000..a8783ee410 --- /dev/null +++ b/extra/math/ranges/ranges-docs.factor @@ -0,0 +1,21 @@ +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 } + { $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 diff --git a/extra/math/ranges/ranges.factor b/extra/math/ranges/ranges.factor index ade3b63a5c..9215fc3acd 100755 --- a/extra/math/ranges/ranges.factor +++ b/extra/math/ranges/ranges.factor @@ -3,7 +3,7 @@ IN: math.ranges TUPLE: range from length step ; -: ( from to step -- range ) +: ( a b step -- range ) >r over - r> [ / 1+ 0 max >integer ] keep range construct-boa ; @@ -22,19 +22,19 @@ INSTANCE: range immutable-sequence : ,b) dup neg rot + swap ; inline -: [a,b] twiddle ; +: [a,b] ( a b -- range ) twiddle ; -: (a,b] twiddle (a, ; +: (a,b] ( a b -- range ) twiddle (a, ; -: [a,b) twiddle ,b) ; +: [a,b) ( a b -- range ) twiddle ,b) ; -: (a,b) twiddle (a, ,b) ; +: (a,b) ( a b -- range ) twiddle (a, ,b) ; -: [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 > ; From fe68d41a11b05be531397acb23edf1c78245435b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 17:46:47 -0500 Subject: [PATCH 041/886] Fix windows time --- extra/windows/time/time.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 extra/windows/time/time.factor diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor old mode 100644 new mode 100755 index e910ca2888..63b12de1ff --- a/extra/windows/time/time.factor +++ b/extra/windows/time/time.factor @@ -8,7 +8,7 @@ IN: windows.time 32 shift bitor ; : windows-1601 ( -- timestamp ) - 1601 1 1 0 0 0 0 ; + 1601 1 1 0 0 0 instant ; : FILETIME>windows-time ( FILETIME -- n ) [ FILETIME-dwLowDateTime ] keep From 3664f7af1bcb4a6d9bb30d1d9aff06f59b001914 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 17:58:35 -0500 Subject: [PATCH 042/886] Fix loader regression --- core/parser/parser-tests.factor | 10 +++++++++- core/vocabs/loader/loader.factor | 6 +++++- core/vocabs/vocabs.factor | 3 +-- 3 files changed, 15 insertions(+), 4 deletions(-) diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index e46f179424..f024eda54c 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -1,7 +1,7 @@ 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 tuples compiler.units debugger vocabs vocabs.loader ; IN: parser.tests [ @@ -461,3 +461,11 @@ must-fail-with ] times [ ] [ "parser" reload ] unit-test + +[ ] [ + [ "this-better-not-exist" forget-vocab ] with-compilation-unit +] unit-test + +[ + "USE: this-better-not-exist" eval +] must-fail diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 103b5290a4..9478c1f4f7 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -113,7 +113,11 @@ M: string (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 diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 38df17c0b5..f111b5bc74 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -64,8 +64,7 @@ ERROR: no-vocab name ; SYMBOL: load-vocab-hook ! ( name -- ) : load-vocab ( name -- vocab ) - dup load-vocab-hook get call - dup vocab [ ] [ vocab-name no-vocab ] ?if ; + dup load-vocab-hook get call vocab ; : vocabs ( -- seq ) dictionary get keys natural-sort ; From 3131e96aa72e146b49a00a5970fa46b128e4276e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 19:54:25 -0500 Subject: [PATCH 043/886] Fixes --- core/parser/parser-docs.factor | 2 +- core/parser/parser.factor | 8 ++++---- extra/http/server/templating/fhtml/fhtml.factor | 2 +- extra/regexp/regexp.factor | 2 +- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 48f929b836..4d200c17d2 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -224,7 +224,7 @@ HELP: skip { $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." } ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 887747d7d8..28822db708 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -60,7 +60,7 @@ t parser-notes set-global [ 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 @@ -68,14 +68,14 @@ t parser-notes set-global 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 <= ; @@ -153,7 +153,7 @@ name>char-hook global [ : parse-string ( -- str ) lexer get [ [ swap tail-slice (parse-string) ] "" make swap - ] change-column ; + ] change-lexer-column ; TUPLE: parse-error file line col text ; diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor index 8567524217..630054ccfa 100755 --- a/extra/http/server/templating/fhtml/fhtml.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -28,7 +28,7 @@ M: template-lexer skip-word { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] } { [ t ] [ f skip ] } } cond - ] change-column ; + ] change-lexer-column ; DEFER: <% delimiter diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index 8a642a8692..b57724d1db 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -292,7 +292,7 @@ TUPLE: regexp source parser ignore-case? ; : parse-regexp ( accum end -- accum ) lexer get dup skip-blank [ [ index* dup 1+ swap ] 2keep swapd subseq swap - ] change-column + ] change-lexer-column lexer get (parse-token) parse-options parsed ; : R! CHAR: ! parse-regexp ; parsing From 69763af858e9b48c0df2843fb04305e000060a03 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 20 Mar 2008 19:08:32 -0600 Subject: [PATCH 044/886] builder.util: new-slots are in core --- extra/builder/util/util.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index 82514ca43d..55ff38d408 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -3,7 +3,7 @@ USING: kernel words namespaces classes parser continuations io io.files io.launcher io.sockets math math.parser 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 ; From dffb45908c9e81348f758065564353e0a81c4db1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 19:56:30 -0500 Subject: [PATCH 045/886] Fixing help failures --- core/generic/generic-docs.factor | 4 ++-- core/generic/math/math-docs.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) mode change 100644 => 100755 core/generic/math/math-docs.factor diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 62b85dde3a..b59c92c798 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -126,7 +126,7 @@ HELP: method { method create-method POSTPONE: M: } related-words HELP: -{ $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 @@ -143,7 +143,7 @@ HELP: check-method { $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 ; diff --git a/core/generic/math/math-docs.factor b/core/generic/math/math-docs.factor old mode 100644 new mode 100755 index cbbf070398..5c15e43eb5 --- a/core/generic/math/math-docs.factor +++ b/core/generic/math/math-docs.factor @@ -15,7 +15,7 @@ HELP: no-math-method 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 } "." } ; From 4b32fa4d0544c235d7d63ca2d795012631184386 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 20:11:45 -0500 Subject: [PATCH 046/886] Fixing help-lint typos --- core/alien/syntax/syntax.factor | 4 ++-- core/io/encodings/encodings-docs.factor | 12 ++++++------ core/io/encodings/encodings.factor | 2 +- core/slots/slots-docs.factor | 10 +++++----- core/slots/slots.factor | 2 +- 5 files changed, 15 insertions(+), 15 deletions(-) diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index 3bd68bfde7..6e4b8b4e21 100755 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -1,4 +1,4 @@ -! 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 @@ -9,7 +9,7 @@ IN: alien.syntax ; : function-quot ( type lib func types -- quot ) diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index 548d2cd7fc..fd5ddaa82d 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -14,19 +14,19 @@ ARTICLE: "encodings-constructors" "Constructing an encoded stream" { $subsection } { $subsection } ; -HELP: ( stream encoding -- newstream ) +HELP: { $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" } "." } ; -HELP: ( stream encoding -- newstream ) +HELP: { $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" } "." } ; -HELP: ( stream-in stream-out encoding -- duplex ) +HELP: { $values { "stream-in" "an input stream" } { "stream-out" "an output stream" } { "encoding" "an encoding descriptor" } @@ -50,12 +50,12 @@ ARTICLE: "encodings-protocol" "Encoding protocol" { $subsection } { $subsection } ; -HELP: decode-char ( stream encoding -- char/f ) +HELP: decode-char { $values { "stream" "an underlying input stream" } - { "encoding" "An encoding descriptor tuple" } } + { "encoding" "An encoding descriptor tuple" } { "char/f" "a code point or " { $link f } } } { $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ; -HELP: encode-char ( char stream encoding -- ) +HELP: encode-char { $values { "char" "a character" } { "stream" "an underlying output stream" } { "encoding" "an encoding descriptor" } } diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 610d294bb6..a781b63ad5 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -12,7 +12,7 @@ GENERIC: decode-char ( stream encoding -- char/f ) GENERIC: encode-char ( char stream encoding -- ) -GENERIC: ( stream decoding -- newstream ) +GENERIC: ( stream encoding -- newstream ) : replacement-char HEX: fffd ; diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 55cff63963..e4bb307829 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -123,8 +123,8 @@ HELP: reader-effect { $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 @@ -132,13 +132,13 @@ HELP: writer-effect { $description "The stack effect of slot writer words is " { $snippet "( value obj -- )" } "." } ; 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-methods -{ $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" } "." } +{ $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-accessors diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 025cf97420..ed5de3a439 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -23,7 +23,7 @@ C: slot-spec [ drop ] [ 1array , \ declare , ] if ] [ ] make ; -: slot-named ( string specs -- spec/f ) +: slot-named ( name specs -- spec/f ) [ slot-spec-name = ] with find nip ; : create-accessor ( name effect -- word ) From 78bd877339d05fe03e92c0c8e2ce3ef1dd48e1e6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 20:12:01 -0500 Subject: [PATCH 047/886] Fix groups set-length --- core/splitting/splitting-tests.factor | 8 +++++++- core/splitting/splitting.factor | 2 +- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/core/splitting/splitting-tests.factor b/core/splitting/splitting-tests.factor index d60403362c..34757e6b22 100644 --- a/core/splitting/splitting-tests.factor +++ b/core/splitting/splitting-tests.factor @@ -1,4 +1,4 @@ -USING: splitting tools.test ; +USING: splitting tools.test kernel sequences arrays ; IN: splitting.tests [ { 1 2 3 } 0 group ] must-fail @@ -56,3 +56,9 @@ unit-test [ { "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 + 2 over set-length + >array +] unit-test diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 6416e27eaf..419a30dda4 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -17,7 +17,7 @@ M: groups length 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 From 3164c857c7e778c0fd6d7c666e158adb0901a19d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 20:13:13 -0500 Subject: [PATCH 048/886] Generic slots for the win --- core/alien/alien.factor | 2 +- core/alien/compiler/compiler.factor | 54 ++++++++++------------------- core/cpu/x86/32/32.factor | 6 ++-- 3 files changed, 23 insertions(+), 39 deletions(-) diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 0afff0c497..436d73e874 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -77,7 +77,7 @@ ERROR: alien-indirect-error ; : alien-indirect ( ... funcptr return parameters abi -- ) alien-indirect-error ; -TUPLE: alien-invoke library function return parameters ; +TUPLE: alien-invoke library function return parameters abi ; ERROR: alien-invoke-error library symbol ; diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index fb7d50e882..3e0062c85a 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -6,14 +6,9 @@ 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 ; +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 ) - : large-struct? ( ctype -- ? ) dup c-struct? [ heap-size struct-small-enough? not @@ -22,11 +17,11 @@ GENERIC: alien-node-abi ( node -- str ) ] 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*" add* ] 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 ; @@ -51,7 +46,7 @@ GENERIC: alien-node-abi ( node -- str ) : 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 + ; @@ -147,9 +142,9 @@ M: long-long-type flatten-value-type ( type -- ) 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 -- ) @@ -161,11 +156,11 @@ M: long-long-type flatten-value-type ( type -- ) ] if ; : make-prep-quot ( node -- quot ) - alien-node-parameters + parameters>> [ (make-prep-quot) ] [ ] make ; : unbox-parameters ( offset node -- ) - alien-node-parameters [ + parameters>> [ %prepare-unbox >r over + r> unbox-parameter ] reverse-each-parameter drop ; @@ -174,7 +169,7 @@ M: long-long-type flatten-value-type ( type -- ) #! 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 -- ) @@ -188,14 +183,7 @@ M: long-long-type flatten-value-type ( type -- ) ] with-param-regs ; : box-return* ( node -- ) - alien-node-return [ ] [ box-return ] if-void ; - -M: alien-invoke alien-node-parameters alien-invoke-parameters ; -M: alien-invoke alien-node-return alien-invoke-return ; - -M: alien-invoke alien-node-abi - alien-invoke-library library - [ library-abi ] [ "cdecl" ] if* ; + return>> [ ] [ box-return ] if-void ; M: alien-invoke-error summary drop @@ -205,7 +193,7 @@ M: alien-invoke-error summary : 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 ; @@ -256,6 +244,10 @@ M: no-such-symbol compiler-error-type pop-literal nip over set-alien-invoke-return ! Quotation which coerces parameters to required types dup make-prep-quot recursive-state get infer-quot + ! Set ABI + dup alien-invoke-library + library [ library-abi ] [ "cdecl" ] if* + over set-alien-invoke-abi ! Add node to IR dup node, ! Magic #: consume exactly the number of inputs @@ -274,10 +266,6 @@ M: alien-invoke generate-node 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." ; @@ -323,10 +311,6 @@ callbacks global [ H{ } assoc-like ] change-at : 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." ; @@ -373,7 +357,7 @@ TUPLE: callback-context ; wait-to-return ; inline : prepare-callback-return ( ctype -- quot ) - alien-node-return { + return>> { { [ dup "void" = ] [ drop [ ] ] } { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] } { [ t ] [ c-type c-type-prep ] } @@ -390,8 +374,8 @@ TUPLE: callback-context ; : callback-unwind ( node -- n ) { - { [ dup alien-node-abi "stdcall" = ] [ alien-stack-frame ] } - { [ dup alien-node-return large-struct? ] [ drop 4 ] } + { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] } + { [ dup return>> large-struct? ] [ drop 4 ] } { [ t ] [ drop 0 ] } } cond ; diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 19b913541c..81a7d7cd02 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -5,7 +5,7 @@ cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot 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 @@ -244,10 +244,10 @@ M: x86-32-backend %cleanup ( alien-node -- ) #! 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 ] From f98dbbbe7471110e2ce29b7132c3359f0f8ca6fc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 20:14:07 -0500 Subject: [PATCH 049/886] Clean up dlists --- core/dlists/dlists-docs.factor | 10 +- core/dlists/dlists-tests.factor | 26 ++-- core/dlists/dlists.factor | 126 +++++++++--------- .../mailboxes/mailboxes-docs.factor | 4 +- .../mailboxes/mailboxes-tests.factor | 14 +- extra/concurrency/mailboxes/mailboxes.factor | 18 +-- extra/concurrency/messaging/messaging.factor | 6 +- 7 files changed, 102 insertions(+), 102 deletions(-) diff --git a/core/dlists/dlists-docs.factor b/core/dlists/dlists-docs.factor index 2aeaadad3e..c957c04453 100755 --- a/core/dlists/dlists-docs.factor +++ b/core/dlists/dlists-docs.factor @@ -85,7 +85,7 @@ HELP: pop-back* { $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 @@ -93,20 +93,20 @@ HELP: dlist-find } ; 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." } ; diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor index cd651bff2f..2bc0e6a3fb 100755 --- a/core/dlists/dlists-tests.factor +++ b/core/dlists/dlists-tests.factor @@ -43,20 +43,20 @@ IN: dlists.tests dlist-front dlist-node-next dlist-node-next ] unit-test -[ f f ] [ [ 1 = ] swap dlist-find ] unit-test -[ 1 t ] [ 1 over push-back [ 1 = ] swap dlist-find ] unit-test -[ f f ] [ 1 over push-back [ 2 = ] swap dlist-find ] unit-test -[ f ] [ 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test -[ t ] [ 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test +[ f f ] [ [ 1 = ] dlist-find ] unit-test +[ 1 t ] [ 1 over push-back [ 1 = ] dlist-find ] unit-test +[ f f ] [ 1 over push-back [ 2 = ] dlist-find ] unit-test +[ f ] [ 1 over push-back [ 2 = ] dlist-contains? ] unit-test +[ t ] [ 1 over push-back [ 1 = ] dlist-contains? ] unit-test -[ 1 ] [ 1 over push-back [ 1 = ] swap delete-node-if ] unit-test -[ t ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test -[ t ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test -[ 0 ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test -[ 1 ] [ 1 over push-back 2 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node-if drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node-if drop dlist-length ] unit-test +[ 1 ] [ 1 over push-back [ 1 = ] delete-node-if ] unit-test +[ t ] [ 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test +[ t ] [ 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test +[ 0 ] [ 1 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test +[ 1 ] [ 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop dlist-length ] unit-test [ 0 ] [ dlist-length ] unit-test [ 1 ] [ 1 over push-front dlist-length ] unit-test diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index 38c4ee233e..56134f3b54 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -1,71 +1,67 @@ -! 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 ; : ( -- obj ) dlist construct-empty - 0 over set-dlist-length ; + 0 >>length ; -: dlist-empty? ( dlist -- ? ) dlist-front not ; +: dlist-empty? ( dlist -- ? ) front>> not ; 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 dup dup set-next-prev ] keep - [ set-dlist-front ] keep + [ front>> f swap dup dup set-next-prev ] keep + [ (>>front) ] keep [ set-back-to-front ] keep inc-length ; @@ -76,9 +72,9 @@ PRIVATE> [ push-front ] curry each ; : push-back* ( obj dlist -- dlist-node ) - [ dlist-back f ] keep - [ dlist-back set-next-when ] 2keep - [ set-dlist-back ] 2keep + [ back>> f ] keep + [ back>> set-next-when ] 2keep + [ (>>back) ] 2keep [ set-front-to-back ] keep inc-length ; @@ -89,70 +85,75 @@ PRIVATE> [ 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* ] } + { [ over front>> over eq? ] [ drop pop-front* ] } + { [ over back>> over eq? ] [ drop pop-back* ] } { [ t ] [ 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? @@ -160,4 +161,3 @@ PRIVATE> inline : 1dlist ( obj -- dlist ) [ push-front ] keep ; - diff --git a/extra/concurrency/mailboxes/mailboxes-docs.factor b/extra/concurrency/mailboxes/mailboxes-docs.factor index 4937ef1fb9..50694776c5 100755 --- a/extra/concurrency/mailboxes/mailboxes-docs.factor +++ b/extra/concurrency/mailboxes/mailboxes-docs.factor @@ -49,8 +49,8 @@ HELP: while-mailbox-empty { $description "Repeatedly call the quotation while there are no items in the mailbox." } ; HELP: mailbox-get? -{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } - { "mailbox" mailbox } +{ $values { "mailbox" mailbox } + { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } { "obj" object } } { $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." } ; diff --git a/extra/concurrency/mailboxes/mailboxes-tests.factor b/extra/concurrency/mailboxes/mailboxes-tests.factor index 24d83b2961..2cb12bcaba 100755 --- a/extra/concurrency/mailboxes/mailboxes-tests.factor +++ b/extra/concurrency/mailboxes/mailboxes-tests.factor @@ -16,9 +16,9 @@ tools.test math kernel strings ; [ V{ 1 2 3 } ] [ 0 - [ [ integer? ] swap mailbox-get? swap push ] in-thread - [ [ integer? ] swap mailbox-get? swap push ] in-thread - [ [ integer? ] swap mailbox-get? swap push ] in-thread + [ [ integer? ] mailbox-get? swap push ] in-thread + [ [ integer? ] mailbox-get? swap push ] in-thread + [ [ integer? ] mailbox-get? swap push ] in-thread 1 over mailbox-put 2 over mailbox-put 3 swap mailbox-put @@ -27,10 +27,10 @@ tools.test math kernel strings ; [ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [ 0 - [ [ integer? ] swap mailbox-get? swap push ] in-thread - [ [ integer? ] swap mailbox-get? swap push ] in-thread - [ [ string? ] swap mailbox-get? swap push ] in-thread - [ [ string? ] swap mailbox-get? swap push ] in-thread + [ [ integer? ] mailbox-get? swap push ] in-thread + [ [ integer? ] mailbox-get? swap push ] in-thread + [ [ string? ] mailbox-get? swap push ] in-thread + [ [ string? ] mailbox-get? swap push ] in-thread 1 over mailbox-put "junk" over mailbox-put [ 456 ] over mailbox-put diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index 28b2fb7221..7b6405679f 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -17,17 +17,17 @@ TUPLE: mailbox threads data ; [ mailbox-data push-front ] keep mailbox-threads notify-all yield ; -: block-unless-pred ( pred mailbox timeout -- ) - 2over mailbox-data dlist-contains? [ +: block-unless-pred ( mailbox timeout pred -- ) + pick mailbox-data over dlist-contains? [ 3drop ] [ - 2dup >r mailbox-threads r> "mailbox" wait + >r over mailbox-threads over "mailbox" wait r> block-unless-pred ] if ; inline : block-if-empty ( mailbox timeout -- mailbox ) over mailbox-empty? [ - 2dup >r mailbox-threads r> "mailbox" wait + over mailbox-threads over "mailbox" wait block-if-empty ] [ drop @@ -58,12 +58,12 @@ TUPLE: mailbox threads data ; 2drop ] if ; inline -: mailbox-get-timeout? ( pred mailbox timeout -- obj ) - [ block-unless-pred ] 3keep drop - mailbox-data delete-node-if ; inline +: mailbox-get-timeout? ( mailbox timeout pred -- obj ) + 3dup block-unless-pred + nip >r mailbox-data r> delete-node-if ; inline -: mailbox-get? ( pred mailbox -- obj ) - f mailbox-get-timeout? ; inline +: mailbox-get? ( mailbox pred -- obj ) + f swap mailbox-get-timeout? ; inline TUPLE: linked-error thread ; diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor index e566a83fdf..2cd83d43f5 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/extra/concurrency/messaging/messaging.factor @@ -26,10 +26,10 @@ M: thread send ( message thread -- ) my-mailbox swap mailbox-get-timeout ?linked ; : receive-if ( pred -- message ) - my-mailbox mailbox-get? ?linked ; inline + my-mailbox swap mailbox-get? ?linked ; inline -: receive-if-timeout ( pred timeout -- message ) - my-mailbox swap mailbox-get-timeout? ?linked ; inline +: receive-if-timeout ( timeout pred -- message ) + my-mailbox -rot mailbox-get-timeout? ?linked ; inline : rethrow-linked ( error process supervisor -- ) >r r> send ; From 59731ee24a7882e0e58917df7297f25ec546b92a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 20:14:16 -0500 Subject: [PATCH 050/886] Use delete-node instead of dlist-delete --- extra/ui/gadgets/gadgets.factor | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index ed3631bca5..267f6f0f0f 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -46,7 +46,7 @@ M: array rect-dim drop { 0 0 } ; TUPLE: gadget 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 ; @@ -254,17 +254,20 @@ M: gadget layout* drop ; : 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 { From e621a92caec52b6f208421c23d613b19e0a98f6c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 20:52:43 -0500 Subject: [PATCH 051/886] -output-image now relative to current directory --- core/bootstrap/stage2.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 2523841aaf..f472e0158f 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -12,7 +12,7 @@ SYMBOL: bootstrap-time : default-image-name ( -- string ) vm file-name windows? [ "." split1 drop ] when - ".image" append ; + ".image" append resource-path ; : do-crossref ( -- ) "Cross-referencing..." print flush @@ -106,5 +106,5 @@ f error-continuation set-global 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 From 314bef5e7804da3033b6674ee8f49fd3821a7fca Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 20:52:58 -0500 Subject: [PATCH 052/886] Add support for -resource-path command line switch --- core/io/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index f9116895e4..21cc7c8f0a 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -190,7 +190,7 @@ DEFER: copy-tree-into ! Special paths : resource-path ( path -- newpath ) - \ resource-path get [ image parent-directory ] unless* + "resource-path" get [ image parent-directory ] unless* prepend-path ; : ?resource-path ( path -- newpath ) From 0d0f0c5ce7bf2c7bd9d7b73a818a181b590de583 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 21:11:53 -0500 Subject: [PATCH 053/886] Improve deployment tool --- extra/bunny/deploy.factor | 15 ++++--- extra/hello-ui/deploy.factor | 13 +++--- extra/hello-world/deploy.factor | 11 ++--- extra/sudoku/deploy.factor | 11 ++--- extra/tools/deploy/backend/backend.factor | 46 +++++++++++++------- extra/tools/deploy/config/config-docs.factor | 17 +++++--- extra/tools/deploy/config/config.factor | 2 + extra/tools/deploy/restage/restage.factor | 8 ++++ extra/tools/deploy/shaker/shaker.factor | 5 +-- extra/tools/deploy/test/1/deploy.factor | 15 ++++--- extra/tools/deploy/test/2/deploy.factor | 15 ++++--- extra/tools/deploy/test/3/deploy.factor | 15 ++++--- extra/ui/tools/deploy/deploy.factor | 1 + 13 files changed, 106 insertions(+), 68 deletions(-) create mode 100644 extra/tools/deploy/restage/restage.factor diff --git a/extra/bunny/deploy.factor b/extra/bunny/deploy.factor index a3f6174726..643737b23c 100755 --- a/extra/bunny/deploy.factor +++ b/extra/bunny/deploy.factor @@ -1,14 +1,15 @@ 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 } } diff --git a/extra/hello-ui/deploy.factor b/extra/hello-ui/deploy.factor index 43d8ca21ef..0ec9c19503 100755 --- a/extra/hello-ui/deploy.factor +++ b/extra/hello-ui/deploy.factor @@ -1,14 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-io 1 } - { deploy-compiler? t } { deploy-word-defs? f } - { deploy-word-props? f } - { deploy-math? t } + { deploy-random? t } { 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 } } diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 2341aabc9d..77421938a9 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,14 +1,15 @@ 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 } } diff --git a/extra/sudoku/deploy.factor b/extra/sudoku/deploy.factor index 11a06f46bc..ba1ac1a32a 100755 --- a/extra/sudoku/deploy.factor +++ b/extra/sudoku/deploy.factor @@ -1,14 +1,15 @@ 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 } } diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 2476077ba9..172a80b612 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -40,42 +40,57 @@ IN: tools.deploy.backend "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" add ] 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 -: 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" , @@ -89,7 +104,6 @@ IN: tools.deploy.backend : make-deploy-image ( vm image vocab config -- ) make-boot-image - dup ?make-staging-image deploy-command-line run-factor ; SYMBOL: deploy-implementation diff --git a/extra/tools/deploy/config/config-docs.factor b/extra/tools/deploy/config/config-docs.factor index 846bb5c274..4af1219daf 100755 --- a/extra/tools/deploy/config/config-docs.factor +++ b/extra/tools/deploy/config/config-docs.factor @@ -16,6 +16,8 @@ ARTICLE: "deploy-flags" "Deployment flags" "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 } @@ -66,16 +68,21 @@ HELP: deploy-math? $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 diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor index c527cb945c..7ebedf7ca1 100755 --- a/extra/tools/deploy/config/config.factor +++ b/extra/tools/deploy/config/config.factor @@ -10,6 +10,7 @@ SYMBOL: deploy-name SYMBOL: deploy-ui? SYMBOL: deploy-compiler? SYMBOL: deploy-math? +SYMBOL: deploy-random? SYMBOL: deploy-threads? SYMBOL: deploy-io @@ -57,6 +58,7 @@ SYMBOL: deploy-image { deploy-reflection 1 } { deploy-compiler? t } { deploy-threads? t } + { deploy-random? t } { deploy-math? t } { deploy-word-props? f } { deploy-word-defs? f } diff --git a/extra/tools/deploy/restage/restage.factor b/extra/tools/deploy/restage/restage.factor new file mode 100644 index 0000000000..c75abf9dd3 --- /dev/null +++ b/extra/tools/deploy/restage/restage.factor @@ -0,0 +1,8 @@ +IN: tools.deploy.restage +USING: bootstrap.stage2 namespaces memory ; + +: restage ( -- ) + load-components + "output-image" get save-image-and-exit ; + +MAIN: restage diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index d31a3460ca..76e4a212b2 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -19,7 +19,6 @@ QUALIFIED: libc.private QUALIFIED: libc.private QUALIFIED: listener QUALIFIED: prettyprint.config -QUALIFIED: random QUALIFIED: source-files QUALIFIED: threads QUALIFIED: vocabs @@ -108,8 +107,6 @@ IN: tools.deploy.shaker : stripped-globals ( -- seq ) [ - random:random-generator , - { bootstrap.stage2:bootstrap-time continuations:error @@ -145,12 +142,14 @@ IN: tools.deploy.shaker vocabs:dictionary lexer-factory vocabs:load-vocab-hook + root-cache layouts:num-tags layouts:num-types layouts:tag-mask layouts:tag-numbers layouts:type-numbers classes:typemap + classes:class-map vocab-roots definitions:crossref compiled-crossref diff --git a/extra/tools/deploy/test/1/deploy.factor b/extra/tools/deploy/test/1/deploy.factor index f06bcbc0f0..490c21a067 100755 --- a/extra/tools/deploy/test/1/deploy.factor +++ b/extra/tools/deploy/test/1/deploy.factor @@ -1,14 +1,15 @@ USING: tools.deploy.config ; H{ + { deploy-word-defs? f } + { deploy-random? f } + { deploy-name "tools.deploy.test.1" } + { deploy-threads? t } + { deploy-compiler? t } + { deploy-math? t } { deploy-c-types? f } { deploy-io 2 } { deploy-reflection 1 } - { deploy-threads? t } - { deploy-word-props? f } - { deploy-word-defs? f } - { deploy-name "tools.deploy.test.1" } - { deploy-math? t } - { deploy-compiler? t } - { "stop-after-last-window?" t } { deploy-ui? f } + { "stop-after-last-window?" t } + { deploy-word-props? f } } diff --git a/extra/tools/deploy/test/2/deploy.factor b/extra/tools/deploy/test/2/deploy.factor index bd087d65bf..b8c37af20a 100755 --- a/extra/tools/deploy/test/2/deploy.factor +++ b/extra/tools/deploy/test/2/deploy.factor @@ -1,14 +1,15 @@ USING: tools.deploy.config ; H{ + { deploy-word-defs? f } + { deploy-random? f } + { deploy-name "tools.deploy.test.2" } + { deploy-threads? t } + { deploy-compiler? t } + { deploy-math? t } { deploy-c-types? f } { deploy-io 2 } { deploy-reflection 1 } - { deploy-threads? t } - { deploy-word-props? f } - { deploy-word-defs? f } - { deploy-name "tools.deploy.test.2" } - { deploy-math? t } - { deploy-compiler? t } - { "stop-after-last-window?" t } { deploy-ui? f } + { "stop-after-last-window?" t } + { deploy-word-props? f } } diff --git a/extra/tools/deploy/test/3/deploy.factor b/extra/tools/deploy/test/3/deploy.factor index b8b8bf4aa2..dde8291658 100755 --- a/extra/tools/deploy/test/3/deploy.factor +++ b/extra/tools/deploy/test/3/deploy.factor @@ -1,14 +1,15 @@ 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 } } diff --git a/extra/ui/tools/deploy/deploy.factor b/extra/ui/tools/deploy/deploy.factor index 9aa763d7ec..eca5740bbc 100755 --- a/extra/ui/tools/deploy/deploy.factor +++ b/extra/ui/tools/deploy/deploy.factor @@ -35,6 +35,7 @@ TUPLE: deploy-gadget vocab settings ; deploy-compiler? get "Use optimizing compiler" gadget, deploy-math? get "Rational and complex number support" gadget, deploy-threads? get "Threading support" gadget, + deploy-random? get "Random number generator support" gadget, deploy-word-props? get "Retain all word properties" gadget, deploy-word-defs? get "Retain all word definitions" gadget, deploy-c-types? get "Retain all C types" gadget, ; From dea825331a45189a54e0fd57dd19d7c302bdebb2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 21:35:01 -0500 Subject: [PATCH 054/886] Fix tools.deploy tests --- extra/tools/deploy/deploy-tests.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 3b88d14fb3..8db34320de 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -28,7 +28,8 @@ namespaces ; [ ] [ "hello-ui" shake-and-bake ] unit-test [ "staging.math-compiler-ui-strip.image" ] [ - "hello-ui" deploy-config [ staging-image-name ] bind + "hello-ui" deploy-config + [ bootstrap-profile staging-image-name file-name ] bind ] unit-test [ t ] [ From 0d86affd2a3b5c273e2897a65a0ca34e5fd9762a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 21:35:32 -0500 Subject: [PATCH 055/886] Fix --- extra/hello-ui/deploy.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/hello-ui/deploy.factor b/extra/hello-ui/deploy.factor index 0ec9c19503..31f1181be2 100755 --- a/extra/hello-ui/deploy.factor +++ b/extra/hello-ui/deploy.factor @@ -1,7 +1,7 @@ USING: tools.deploy.config ; H{ { deploy-word-defs? f } - { deploy-random? t } + { deploy-random? f } { deploy-name "Hello world" } { deploy-threads? t } { deploy-compiler? t } From a614e2e8e4d83f161dcf3aa17d59a86795a424ec Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 21:55:40 -0500 Subject: [PATCH 056/886] Minor documentation updates --- core/compiler/compiler-docs.factor | 3 ++- core/compiler/units/units-docs.factor | 4 +++- core/syntax/syntax-docs.factor | 3 +++ 3 files changed, 8 insertions(+), 2 deletions(-) diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index 7196a4b4fb..3520104e1f 100755 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -8,7 +8,8 @@ $nl "The main entry point to the optimizing compiler:" { $subsection optimized-recompile-hook } "Removing a word's optimized definition:" -{ $subsection decompile } ; +{ $subsection decompile } +"These words are not usually used directly. Instead, use " { $link "compilation-units" } "." ; ARTICLE: "compiler" "Optimizing compiler" "Factor is a fully compiled language implementation with two distinct compilers:" diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor index 74dac17be8..09baf91018 100755 --- a/core/compiler/units/units-docs.factor +++ b/core/compiler/units/units-docs.factor @@ -9,7 +9,9 @@ $nl $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" } "):" diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 26562a2178..c0ceb4119a 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -227,6 +227,9 @@ HELP: foldable } "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 From c0c9479196cca03c35183013f89c2ec964b80525 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 16:57:13 -0500 Subject: [PATCH 057/886] add file-info test --- core/io/files/files-tests.factor | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index e347e3e3d6..739b55882d 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,5 +1,6 @@ IN: io.files.tests -USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; +USING: tools.test io.files io threads kernel continuations io.encodings.ascii +io.files.unique sequences strings accessors ; [ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test [ ] [ "blahblah" temp-file make-directory ] unit-test @@ -131,3 +132,15 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; [ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test [ ] [ "append-test" ascii dispose ] unit-test + + + +[ 123 ] [ + "core" ".test" [ + [ + ascii [ + 123 CHAR: a >string write + ] with-file-writer + ] keep file-info size>> + ] with-unique-file +] unit-test From a96074997589c0e9b0c3e467355f53482990e605 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 16 Mar 2008 17:07:43 -0500 Subject: [PATCH 058/886] fix openbsd types --- extra/unix/stat/openbsd/32/32.factor | 29 -------------------- extra/unix/stat/openbsd/64/64.factor | 29 -------------------- extra/unix/stat/openbsd/openbsd.factor | 32 ++++++++++++++++++---- extra/unix/types/openbsd/32/32.factor | 29 -------------------- extra/unix/types/openbsd/64/64.factor | 29 -------------------- extra/unix/types/openbsd/openbsd.factor | 36 ++++++++++++++++++++----- 6 files changed, 57 insertions(+), 127 deletions(-) delete mode 100644 extra/unix/stat/openbsd/32/32.factor delete mode 100644 extra/unix/stat/openbsd/64/64.factor delete mode 100755 extra/unix/types/openbsd/32/32.factor delete mode 100755 extra/unix/types/openbsd/64/64.factor mode change 100644 => 100755 extra/unix/types/openbsd/openbsd.factor diff --git a/extra/unix/stat/openbsd/32/32.factor b/extra/unix/stat/openbsd/32/32.factor deleted file mode 100644 index 61a37ba567..0000000000 --- a/extra/unix/stat/openbsd/32/32.factor +++ /dev/null @@ -1,29 +0,0 @@ -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" "st_qspare1" } - { "int64_t" "st_qspare2" } ; - -FUNCTION: int stat ( char* pathname, stat* buf ) ; -FUNCTION: int lstat ( char* pathname, stat* buf ) ; diff --git a/extra/unix/stat/openbsd/64/64.factor b/extra/unix/stat/openbsd/64/64.factor deleted file mode 100644 index 61a37ba567..0000000000 --- a/extra/unix/stat/openbsd/64/64.factor +++ /dev/null @@ -1,29 +0,0 @@ -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" "st_qspare1" } - { "int64_t" "st_qspare2" } ; - -FUNCTION: int stat ( char* pathname, stat* buf ) ; -FUNCTION: int lstat ( char* pathname, stat* buf ) ; diff --git a/extra/unix/stat/openbsd/openbsd.factor b/extra/unix/stat/openbsd/openbsd.factor index 0a2312302b..38ebf66abc 100644 --- a/extra/unix/stat/openbsd/openbsd.factor +++ b/extra/unix/stat/openbsd/openbsd.factor @@ -1,7 +1,29 @@ -USING: layouts combinators vocabs.loader ; +USING: kernel alien.syntax math ; IN: unix.stat -cell-bits { - { 32 [ "unix.stat.openbsd.32" require ] } - { 64 [ "unix.stat.openbsd.64" require ] } -} case +! 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" "st_qspare1" } + { "int64_t" "st_qspare2" } ; + +FUNCTION: int stat ( char* pathname, stat* buf ) ; +FUNCTION: int lstat ( char* pathname, stat* buf ) ; diff --git a/extra/unix/types/openbsd/32/32.factor b/extra/unix/types/openbsd/32/32.factor deleted file mode 100755 index 221f9896b0..0000000000 --- a/extra/unix/types/openbsd/32/32.factor +++ /dev/null @@ -1,29 +0,0 @@ -USING: alien.syntax ; -IN: unix.types - -! OpenBSD 4.2 - -TYPEDEF: ushort __uint16_t -TYPEDEF: uint __uint32_t -TYPEDEF: int __int32_t -TYPEDEF: longlong __int64_t - -TYPEDEF: int int32_t -TYPEDEF: int 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 ino_t -TYPEDEF: __uint16_t mode_t -TYPEDEF: __uint16_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 diff --git a/extra/unix/types/openbsd/64/64.factor b/extra/unix/types/openbsd/64/64.factor deleted file mode 100755 index b24cc94a90..0000000000 --- a/extra/unix/types/openbsd/64/64.factor +++ /dev/null @@ -1,29 +0,0 @@ -USING: alien.syntax ; -IN: unix.types - -! OpenBSD 4.2 - -TYPEDEF: ushort __uint16_t -TYPEDEF: uint __uint32_t -TYPEDEF: int __int32_t -TYPEDEF: longlong __int64_t - -TYPEDEF: int int32_t -TYPEDEF: int 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 ino_t -TYPEDEF: __uint32_t mode_t -TYPEDEF: __uint32_t nlink_t -TYPEDEF: __uint32_t uid_t -TYPEDEF: __uint32_t gid_t -TYPEDEF: __uint64_t off_t -TYPEDEF: __uint64_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 diff --git a/extra/unix/types/openbsd/openbsd.factor b/extra/unix/types/openbsd/openbsd.factor old mode 100644 new mode 100755 index 9d2508e91c..7445dada2b --- a/extra/unix/types/openbsd/openbsd.factor +++ b/extra/unix/types/openbsd/openbsd.factor @@ -1,7 +1,31 @@ -USING: layouts combinators vocabs.loader ; -IN: unix.stat +USING: alien.syntax ; +IN: unix.types -cell-bits { - { 32 [ "unix.types.openbsd.32" require ] } - { 64 [ "unix.types.openbsd.64" require ] } -} case +! 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: int 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 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 From 84c327d60634ac9dbb8c42a5fff358efbb8b6acb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 23:32:48 -0500 Subject: [PATCH 059/886] fix help lint error --- extra/io/files/unique/unique-docs.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/io/files/unique/unique-docs.factor b/extra/io/files/unique/unique-docs.factor index fcfcc15678..01b8e131cc 100644 --- a/extra/io/files/unique/unique-docs.factor +++ b/extra/io/files/unique/unique-docs.factor @@ -12,7 +12,7 @@ ARTICLE: "unique" "Making and using unique files" 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" } } { $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." } @@ -26,7 +26,8 @@ HELP: make-unique-directory ( -- path ) { $see-also with-unique-directory } ; HELP: with-unique-file ( prefix suffix quot -- ) -{ $values { "quot" "a quotation" } } +{ $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." } ; From b362175d436099b4214e88a861eb15e721059d86 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 18 Mar 2008 17:01:14 -0400 Subject: [PATCH 060/886] Initial optimization of encodings --- core/io/encodings/encodings-docs.factor | 30 +++++------ core/io/encodings/encodings.factor | 19 ++++--- core/io/encodings/utf8/utf8.factor | 2 +- core/io/streams/byte-array/byte-array.factor | 4 +- core/io/streams/string/string.factor | 5 +- extra/io/encodings/ascii/ascii.factor | 8 +-- extra/io/encodings/utf16/utf16.factor | 56 +++++++++----------- extra/io/unix/launcher/launcher-tests.factor | 8 +-- 8 files changed, 65 insertions(+), 67 deletions(-) diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index e5e71b05f0..548d2cd7fc 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -44,25 +44,21 @@ $nl { $vocab-link "io.encodings.utf16" } ; 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 } ; +{ $subsection decode-char } +{ $subsection encode-char } +"The following methods are optional:" +{ $subsection } +{ $subsection } ; -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" } +HELP: decode-char ( stream encoding -- char/f ) +{ $values { "stream" "an underlying input 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." } ; +{ $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ; -HELP: stream-write-encoded ( string stream encoding -- ) -{ $values { "string" "a string" } - { "stream" "an output stream" } +HELP: encode-char ( char stream encoding -- ) +{ $values { "char" "a character" } + { "stream" "an underlying 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." } ; +{ $description "Writes the code point in the encoding to the underlying stream given. This should not be used directly." } ; -HELP: init-decoder ( stream encoding -- encoding ) -{ $values { "stream" "an input 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." } ; - -{ init-decoder decode-step stream-write-encoded } related-words +{ encode-char decode-char } related-words diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index b7c71d5527..4cd43ef455 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -61,25 +61,28 @@ M: tuple f decoder construct-boa ; ] when nip ; : read-loop ( n stream -- string ) - over 0 [ + SBUF" " clone [ [ - >r stream-read1 dup - [ swap r> set-nth-unsafe f ] [ r> 3drop t ] if - ] 2curry find-integer - ] keep swap [ head ] when* ; + >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 read-loop fix-read ; +M: decoder stream-read-partial stream-read ; + : (read-until) ( buf quot -- string/f sep/f ) - ! quot: -- char keep-going? + ! quot: -- char stop? dup call [ >r drop "" like r> ] [ pick push (read-until) ] if ; inline M: decoder stream-read-until SBUF" " clone -rot >decoder< - [ decode-char dup rot memq? ] 3curry (read-until) ; + [ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry + (read-until) ; : fix-read1 ( stream char -- char ) over decoder-cr [ @@ -118,6 +121,8 @@ M: encoder stream-write 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 diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index 02b10c45a5..e98860f25d 100644 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -15,7 +15,7 @@ TUPLE: utf8 ; : append-nums ( stream byte -- stream char ) over stream-read1 dup starts-2? - [ 6 shift swap BIN: 111111 bitand bitor ] + [ swap 6 shift swap BIN: 111111 bitand bitor ] [ 2drop replacement-char ] if ; : double ( stream byte -- stream char ) diff --git a/core/io/streams/byte-array/byte-array.factor b/core/io/streams/byte-array/byte-array.factor index d5ca8eac68..2a8441ff23 100644 --- a/core/io/streams/byte-array/byte-array.factor +++ b/core/io/streams/byte-array/byte-array.factor @@ -1,5 +1,5 @@ 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 : ( encoding -- stream ) @@ -7,7 +7,7 @@ IN: io.streams.byte-array : with-byte-writer ( encoding quot -- byte-array ) >r r> [ stdio get ] compose with-stream* - >byte-array ; inline + dup encoder? [ encoder-stream ] when >byte-array ; inline : ( byte-array encoding -- stream ) >r >byte-vector dup reverse-here r> ; diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index 33404292a9..b7ff37a971 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -49,8 +49,11 @@ M: growable stream-read M: growable stream-read-partial stream-read ; +TUPLE: null ; +M: null decode-char drop stream-read1 ; + : ( str -- stream ) - >sbuf dup reverse-here f ; + >sbuf dup reverse-here null ; : with-string-reader ( str quot -- ) >r r> with-stream ; inline diff --git a/extra/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor index 16d87ef39c..d3fe51f28d 100644 --- a/extra/io/encodings/ascii/ascii.factor +++ b/extra/io/encodings/ascii/ascii.factor @@ -1,14 +1,16 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.encodings kernel math ; +USING: io io.encodings kernel math io.encodings.private ; IN: io.encodings.ascii [ encode-error ] [ stream-write1 ] if ; + nip 1- pick < [ encode-error ] [ stream-write1 ] if ; : decode-if< ( stream encoding max -- character ) - nip swap stream-read1 tuck > [ drop replacement-character ] unless ; + nip swap stream-read1 + [ tuck > [ drop replacement-char ] unless ] + [ drop f ] if* ; PRIVATE> TUPLE: ascii ; diff --git a/extra/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor index 7e82935db7..290761ec91 100755 --- a/extra/io/encodings/utf16/utf16.factor +++ b/extra/io/encodings/utf16/utf16.factor @@ -1,14 +1,14 @@ ! 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 ; +io.encodings combinators splitting io byte-arrays inspector ; IN: io.encodings.utf16 TUPLE: utf16be ; -TUPLE: utf16le ch state ; +TUPLE: utf16le ; -TUPLE: utf16 started? ; +TUPLE: utf16 ; r 2 shift r> BIN: 11 bitand bitor over stream-read1 swap append-nums HEX: 10000 + - ] [ 2drop replacement-char ] if - ] when ; + ] [ 2drop dup stream-read1 drop replacement-char ] if + ] when* ; : ignore ( stream -- stream char ) dup stream-read1 drop replacement-char ; @@ -38,7 +38,7 @@ TUPLE: utf16 started? ; [ drop ignore ] if ] [ double-be ] if ; -M: decode-char +M: utf16be decode-char drop dup stream-read1 dup [ begin-utf16be ] when nip ; ! UTF-16LE decoding @@ -54,59 +54,48 @@ M: decode-char dup BIN: 100 bitand 0 number= [ BIN: 11 bitand 8 shift bitor quad-le ] [ 2drop replacement-char ] if - ] [ swap append-nums ] if ; - -: decode-utf16le-step ( buf byte ch state -- buf ch state ) - { - { begin [ drop double ] } - { double [ handle-double ] } - { quad2 [ 10 shift bitor quad3 ] } - { quad3 [ handle-quad3le ] } - } case ; + ] [ append-nums ] if ; : begin-utf16le ( stream byte -- stream char ) - over stream-read1 [ double-le ] [ drop replacement-char ] if* + over stream-read1 [ double-le ] [ drop replacement-char ] if* ; -M: decode-char +M: utf16le decode-char drop dup stream-read1 dup [ begin-utf16le ] when nip ; ! UTF-16LE/BE encoding -: encode-first +: encode-first ( char -- byte1 byte2 ) -10 shift dup -8 shift BIN: 11011000 bitor swap HEX: FF bitand ; -: encode-second +: 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 ] 2apply ; + rot [ stream-write1 ] curry 2apply ; : char>utf16be ( stream char -- ) dup HEX: FFFF > [ HEX: 10000 - - dup encode-first stream-write2 + 2dup encode-first stream-write2 encode-second stream-write2 ] [ h>b/b swap stream-write2 ] if ; M: utf16be encode-char ( char stream encoding -- ) - drop char>utf16be ; + drop swap char>utf16be ; -: char>utf16le ( char -- ) +: char>utf16le ( char stream -- ) dup HEX: FFFF > [ HEX: 10000 - - dup encode-first swap stream-write2 + 2dup encode-first swap stream-write2 encode-second swap stream-write2 ] [ h>b/b stream-write2 ] if ; -: stream-write-utf16le ( string stream -- ) - [ [ char>utf16le ] each ] with-stream* ; - -M: utf16le stream-write-encoded ( string stream encoding -- ) - drop stream-write-utf16le ; +M: utf16le encode-char ( char stream encoding -- ) + drop swap char>utf16le ; ! UTF-16 @@ -118,13 +107,16 @@ M: utf16le stream-write-encoded ( string stream encoding -- ) : 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 ] [ decode-error ] if + bom-be sequence= [ utf16be ] [ missing-bom ] if ] if ; M: utf16 ( stream utf16 -- decoder ) - 2 rot stream-read bom>le/be ; + drop 2 over stream-read bom>le/be ; M: utf16 ( stream utf16 -- encoder ) drop bom-le over stream-write utf16le ; diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index aa54d3ec94..5370817d2f 100644 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -1,6 +1,6 @@ IN: io.unix.launcher.tests USING: io.files tools.test io.launcher arrays io namespaces -continuations math io.encodings.ascii io.encodings.latin1 +continuations math io.encodings.binary io.encodings.ascii accessors kernel sequences ; [ ] [ @@ -64,7 +64,7 @@ accessors kernel sequences ; [ ] [ 2 [ - "launcher-test-1" temp-file ascii [ + "launcher-test-1" temp-file binary [ swap >>stdout "echo Hello" >>command @@ -84,7 +84,7 @@ accessors kernel sequences ; "env" >>command { { "A" "B" } } >>environment - latin1 lines + ascii lines "A=B" swap member? ] unit-test @@ -93,5 +93,5 @@ accessors kernel sequences ; "env" >>command { { "A" "B" } } >>environment +replace-environment+ >>environment-mode - latin1 lines + ascii lines ] unit-test From a855846b764dc5c31d1197b8305ced25fab01c74 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 19 Mar 2008 19:43:36 -0500 Subject: [PATCH 061/886] cairo dll update --- extra/cairo/ffi/ffi.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor index d7aa90c464..76ce27975b 100644 --- a/extra/cairo/ffi/ffi.factor +++ b/extra/cairo/ffi/ffi.factor @@ -13,7 +13,7 @@ USING: alien alien.syntax combinators system ; IN: cairo.ffi << "cairo" { - { [ win32? ] [ "cairo.dll" ] } + { [ win32? ] [ "libcairo-2.dll" ] } ! { [ macosx? ] [ "libcairo.dylib" ] } { [ macosx? ] [ "/opt/local/lib/libcairo.dylib" ] } { [ unix? ] [ "libcairo.so.2" ] } From 55a8c991ad329bdc53edfcd03722016474be9ec0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 18 Mar 2008 18:59:37 -0500 Subject: [PATCH 062/886] fix gmt-offset on windows --- extra/calendar/windows/windows.factor | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor index 1609b9f260..6986902ff1 100755 --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -1,22 +1,21 @@ USING: calendar.backend namespaces alien.c-types -windows windows.kernel32 kernel math ; +windows windows.kernel32 kernel math combinators.cleave +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 ( -- hours minutes seconds ) - 0 0 0 ; - ! "TIME_ZONE_INFORMATION" - ! dup GetTimeZoneInformation { - ! { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] } - ! { [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ] - ! [ TIME_ZONE_INFORMATION-Bias 60 / neg ] } - ! { [ dup TIME_ZONE_ID_DAYLIGHT = ] [ - ! [ TIME_ZONE_INFORMATION-Bias 60 / neg ] - ! [ TIME_ZONE_INFORMATION-DaylightBias ] bi - ! ] } - ! } cond ; + "TIME_ZONE_INFORMATION" + dup GetTimeZoneInformation { + { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error-string throw ] } + { [ dup [ TIME_ZONE_ID_UNKNOWN = ] [ TIME_ZONE_ID_STANDARD = ] bi or ] [ + drop TIME_ZONE_INFORMATION-Bias ] } + { [ dup TIME_ZONE_ID_DAYLIGHT = ] [ + drop + [ TIME_ZONE_INFORMATION-Bias ] + [ TIME_ZONE_INFORMATION-DaylightBias ] bi + + ] } + } cond neg 60 /mod 0 ; From 4b37c9098ef8be2b9471d80d889af7bbe1d61d81 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 19 Mar 2008 16:54:42 +1300 Subject: [PATCH 063/886] Use multiline for parsing EBNF string --- extra/peg/ebnf/ebnf.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 5d7d7297ef..4563783ab0 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel parser words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg - peg.parsers unicode.categories ; + peg.parsers unicode.categories multiline ; IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; @@ -182,4 +182,4 @@ DEFER: 'choice' f ] if* ; -: " parse-tokens " " join ebnf>quot call ; parsing +: " parse-multiline-string ebnf>quot call ; parsing From cc9a17b551980b43b016bdc7154bcf7c65d12ccf Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 19 Mar 2008 17:00:53 +1300 Subject: [PATCH 064/886] Use choice* and seq* in ebnf --- extra/peg/ebnf/ebnf.factor | 70 ++++++++++++++++++++++++-------------- 1 file changed, 45 insertions(+), 25 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 4563783ab0..81fc215bd9 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -100,33 +100,46 @@ M: ebnf (generate-parser) ( ast -- id ) DEFER: 'rhs' : 'non-terminal' ( -- parser ) - CHAR: a CHAR: z range "-" token [ first ] action 2array choice repeat1 [ >string ] action ; + [ + CHAR: a CHAR: z range , + "-" token [ first ] action , + ] choice* repeat1 [ >string ] action ; : 'terminal' ( -- parser ) - "'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string ] action ; + [ + "'" token hide , + [ CHAR: ' = not ] satisfy repeat1 , + "'" token hide , + ] seq* [ first >string ] action ; : 'element' ( -- parser ) - 'non-terminal' 'terminal' 2array choice ; + [ + 'non-terminal' , + 'terminal' , + ] choice* ; DEFER: 'choice' : 'group' ( -- parser ) - "(" token sp hide - [ 'choice' sp ] delay - ")" token sp hide - 3array seq [ first ] action ; + [ + "(" token sp hide , + [ 'choice' sp ] delay , + ")" token sp hide , + ] seq* [ first ] action ; : 'repeat0' ( -- parser ) - "{" token sp hide - [ 'choice' sp ] delay - "}" token sp hide - 3array seq [ first ] action ; + [ + "{" token sp hide , + [ 'choice' sp ] delay , + "}" token sp hide , + ] seq* [ first ] action ; : 'optional' ( -- parser ) - "[" token sp hide - [ 'choice' sp ] delay - "]" token sp hide - 3array seq [ first ] action ; + [ + "[" token sp hide , + [ 'choice' sp ] delay , + "]" token sp hide , + ] seq* [ first ] action ; : 'sequence' ( -- parser ) [ @@ -134,8 +147,7 @@ DEFER: 'choice' 'group' sp , 'repeat0' sp , 'optional' sp , - ] { } make choice - repeat1 [ + ] choice* repeat1 [ dup length 1 = [ first ] [ ] if ] action ; @@ -145,18 +157,26 @@ DEFER: 'choice' ] action ; : 'action' ( -- parser ) - "=>" token hide - [ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp - 2array seq [ first ] action ; + [ + "=>" token hide , + [ + [ blank? ] satisfy ensure-not , + [ drop t ] satisfy , + ] seq* [ first ] action repeat1 [ >string ] action sp , + ] seq* [ first ] action ; : 'rhs' ( -- parser ) - 'choice' 'action' sp optional 2array seq ; + [ + 'choice' , + 'action' sp optional , + ] seq* ; : 'rule' ( -- parser ) - 'non-terminal' [ ebnf-non-terminal-symbol ] action - "=" token sp hide - 'rhs' - 3array seq [ first2 ] action ; + [ + 'non-terminal' [ ebnf-non-terminal-symbol ] action , + "=" token sp hide , + 'rhs' , + ] seq* [ first2 ] action ; : 'ebnf' ( -- parser ) 'rule' sp "." token sp hide list-of [ ] action ; From 757853812271dbeb31c97f5d33d2f4bf14f9f55f Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 19 Mar 2008 17:34:28 +1300 Subject: [PATCH 065/886] Minor tidyup of ebnf --- extra/peg/ebnf/ebnf-tests.factor | 17 +++++++++++++ extra/peg/ebnf/ebnf.factor | 42 ++++++++++++++++++++++++-------- 2 files changed, 49 insertions(+), 10 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 452da8df05..156f8e9389 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -97,3 +97,20 @@ IN: peg.ebnf.tests } [ "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 + diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 81fc215bd9..9a3b70fa1c 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel parser words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg - peg.parsers unicode.categories multiline ; + peg.parsers unicode.categories multiline combinators.lib ; IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; @@ -99,18 +99,40 @@ M: ebnf (generate-parser) ( ast -- id ) DEFER: 'rhs' +: 'identifier' ( -- parser ) + #! Return a parser that parses an identifer delimited by + #! a quotation character. The quotation can be single + #! or double quotes. The AST produced is the identifier + #! between the quotes. + [ + [ CHAR: " = not ] satisfy repeat1 "\"" "\"" surrounded-by , + [ CHAR: ' = not ] satisfy repeat1 "'" "'" surrounded-by , + ] choice* [ >string ] action ; + : 'non-terminal' ( -- parser ) - [ - CHAR: a CHAR: z range , - "-" token [ first ] action , - ] choice* repeat1 [ >string ] action ; + #! A non-terminal is the name of another rule. It can + #! be any non-blank character except for characters used + #! in the EBNF syntax itself. + [ + { + [ dup blank? ] + [ dup CHAR: " = ] + [ dup CHAR: ' = ] + [ dup CHAR: | = ] + [ dup CHAR: { = ] + [ dup CHAR: } = ] + [ dup CHAR: = = ] + [ dup CHAR: ) = ] + [ dup CHAR: ( = ] + [ dup CHAR: ] = ] + [ dup CHAR: [ = ] + } || not nip + ] satisfy repeat1 [ >string ] action ; : 'terminal' ( -- parser ) - [ - "'" token hide , - [ CHAR: ' = not ] satisfy repeat1 , - "'" token hide , - ] seq* [ first >string ] action ; + #! A terminal is an identifier enclosed in quotations + #! and it represents the literal value of the identifier. + 'identifier' [ ] action ; : 'element' ( -- parser ) [ From 708d55fb8ef4777cb3464b498d794d04a7f96a3a Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 19 Mar 2008 17:37:08 +1300 Subject: [PATCH 066/886] Add syntax word for ebnf --- extra/peg/ebnf/ebnf.factor | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 9a3b70fa1c..e2977a28fb 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -99,6 +99,11 @@ M: ebnf (generate-parser) ( ast -- id ) DEFER: 'rhs' +: syntax ( string -- parser ) + #! Parses the string, ignoring white space, and + #! does not put the result in the AST. + token sp hide ; + : 'identifier' ( -- parser ) #! Return a parser that parses an identifer delimited by #! a quotation character. The quotation can be single @@ -144,23 +149,23 @@ DEFER: 'choice' : 'group' ( -- parser ) [ - "(" token sp hide , + "(" syntax , [ 'choice' sp ] delay , - ")" token sp hide , + ")" syntax , ] seq* [ first ] action ; : 'repeat0' ( -- parser ) [ - "{" token sp hide , + "{" syntax , [ 'choice' sp ] delay , - "}" token sp hide , + "}" syntax , ] seq* [ first ] action ; : 'optional' ( -- parser ) [ - "[" token sp hide , + "[" syntax , [ 'choice' sp ] delay , - "]" token sp hide , + "]" syntax , ] seq* [ first ] action ; : 'sequence' ( -- parser ) @@ -196,12 +201,12 @@ DEFER: 'choice' : 'rule' ( -- parser ) [ 'non-terminal' [ ebnf-non-terminal-symbol ] action , - "=" token sp hide , + "=" syntax , 'rhs' , ] seq* [ first2 ] action ; : 'ebnf' ( -- parser ) - 'rule' sp "." token sp hide list-of [ ] action ; + 'rule' sp "." syntax list-of [ ] action ; : ebnf>quot ( string -- quot ) 'ebnf' parse [ From 9403d97e22c1e0e59ce4285b033b4db5e4f18b2b Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 19 Mar 2008 17:52:22 +1300 Subject: [PATCH 067/886] Add syntax-pack and grouped to ebnf refactoring --- extra/peg/ebnf/ebnf.factor | 35 +++++++++++++++++------------------ 1 file changed, 17 insertions(+), 18 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index e2977a28fb..fce7a8d3bd 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -104,6 +104,11 @@ DEFER: 'rhs' #! does not put the result in the AST. token sp hide ; +: syntax-pack ( begin parser end -- parser ) + #! Parse 'parser' surrounded by syntax elements + #! begin and end. + [ syntax ] dipd syntax pack ; + : 'identifier' ( -- parser ) #! Return a parser that parses an identifer delimited by #! a quotation character. The quotation can be single @@ -147,26 +152,20 @@ DEFER: 'rhs' DEFER: 'choice' +: grouped ( begin quot end -- parser ) + #! Parse a group of choices, where the delimiter for the + #! group is specified by 'begin' and 'end'. The quotation + #! should produce the AST to be the result of the parser. + [ [ 'choice' sp ] delay swap action ] dip syntax-pack ; + : 'group' ( -- parser ) - [ - "(" syntax , - [ 'choice' sp ] delay , - ")" syntax , - ] seq* [ first ] action ; + "(" [ ] ")" grouped ; : 'repeat0' ( -- parser ) - [ - "{" syntax , - [ 'choice' sp ] delay , - "}" syntax , - ] seq* [ first ] action ; + "{" [ ] "}" grouped ; : 'optional' ( -- parser ) - [ - "[" syntax , - [ 'choice' sp ] delay , - "]" syntax , - ] seq* [ first ] action ; + "[" [ ] "]" grouped ; : 'sequence' ( -- parser ) [ @@ -174,14 +173,14 @@ DEFER: 'choice' 'group' sp , 'repeat0' sp , 'optional' sp , - ] choice* repeat1 [ + ] choice* repeat1 [ dup length 1 = [ first ] [ ] if - ] action ; + ] action ; : 'choice' ( -- parser ) 'sequence' sp "|" token sp list-of [ dup length 1 = [ first ] [ ] if - ] action ; + ] action ; : 'action' ( -- parser ) [ From eef6ae782730ba22a779997023c20d71730abcae Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 19 Mar 2008 18:07:25 +1300 Subject: [PATCH 068/886] Remove need for '.' to terminate rule lines in EBNF --- extra/peg/ebnf/ebnf.factor | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index fce7a8d3bd..e95fc4f9d4 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -145,10 +145,17 @@ DEFER: 'rhs' 'identifier' [ ] action ; : 'element' ( -- parser ) - [ - 'non-terminal' , - 'terminal' , - ] choice* ; + #! An element of a rule. It can be a terminal or a + #! non-terminal but must not be followed by a "=". + #! The latter indicates that it is the beginning of a + #! new rule. + [ + [ + 'non-terminal' , + 'terminal' , + ] choice* , + "=" syntax ensure-not , + ] seq* [ first ] action ; DEFER: 'choice' @@ -168,6 +175,8 @@ DEFER: 'choice' "[" [ ] "]" grouped ; : 'sequence' ( -- parser ) + #! A sequence of terminals and non-terminals, including + #! groupings of those. [ 'element' sp , 'group' sp , @@ -205,7 +214,7 @@ DEFER: 'choice' ] seq* [ first2 ] action ; : 'ebnf' ( -- parser ) - 'rule' sp "." syntax list-of [ ] action ; + 'rule' sp repeat1 [ ] action ; : ebnf>quot ( string -- quot ) 'ebnf' parse [ From 208c88c44949f72f62d9cd6ffbf700d301232963 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 19 Mar 2008 18:35:45 +1300 Subject: [PATCH 069/886] Update pl0 for ebnf changes, and add more tests --- extra/peg/pl0/pl0-tests.factor | 88 +++++++++++++++++++++++++++++++++- extra/peg/pl0/pl0.factor | 35 +++++++------- 2 files changed, 105 insertions(+), 18 deletions(-) diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor index fa8ac89f57..bf321d54e9 100644 --- a/extra/peg/pl0/pl0-tests.factor +++ b/extra/peg/pl0/pl0-tests.factor @@ -1,7 +1,7 @@ ! 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.pl0 multiline sequences ; IN: peg.pl0.tests { "abc" } [ @@ -11,3 +11,89 @@ IN: peg.pl0.tests { 55 } [ "55abc" number parse parse-result-ast ] 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. +"> program parse 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. + "> program parse parse-result-remaining empty? +] unit-test \ No newline at end of file diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor index 6844eb44dc..1ef7a23b41 100644 --- a/extra/peg/pl0/pl0.factor +++ b/extra/peg/pl0/pl0.factor @@ -1,30 +1,31 @@ ! 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 ; 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 ; + [ + CHAR: a CHAR: z range , + CHAR: A CHAR: Z range , + ] choice* repeat1 [ >string ] action ; MEMO: number ( -- parser ) CHAR: 0 CHAR: 9 range repeat1 [ string>number ] action ; =' | '>') expression . -expression = ['+' | '-'] term {('+' | '-') term } . -term = factor {('*' | '/') factor } . -factor = ident | number | '(' expression ')' +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> From 64135b73e1b029c49af511a9d32307b5c473b52a Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 19 Mar 2008 19:15:52 +1300 Subject: [PATCH 070/886] Add support for ensure-not and parsing any single character to EBNF This allows, for example: foo = {!("_" | "-") .} This will match zero or more of any character, except for _ or - --- extra/peg/ebnf/ebnf-tests.factor | 1 + extra/peg/ebnf/ebnf.factor | 27 +++++++++++++++++++++++++++ 2 files changed, 28 insertions(+) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 156f8e9389..86a7a454ed 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -114,3 +114,4 @@ IN: peg.ebnf.tests "foo]" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol ] unit-test + diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index e95fc4f9d4..4dc096ecbd 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -7,6 +7,8 @@ IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; TUPLE: ebnf-terminal symbol ; +TUPLE: ebnf-any-character ; +TUPLE: ebnf-ensure-not group ; TUPLE: ebnf-choice options ; TUPLE: ebnf-sequence elements ; TUPLE: ebnf-repeat0 group ; @@ -17,6 +19,8 @@ TUPLE: ebnf rules ; C: ebnf-non-terminal C: ebnf-terminal +C: ebnf-any-character +C: ebnf-ensure-not C: ebnf-choice C: ebnf-sequence C: ebnf-repeat0 @@ -61,6 +65,9 @@ M: ebnf-non-terminal (generate-parser) ( ast -- id ) parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or , ] [ ] make delay sp store-parser ; +M: ebnf-any-character (generate-parser) ( ast -- id ) + drop [ drop t ] satisfy store-parser ; + M: ebnf-choice (generate-parser) ( ast -- id ) ebnf-choice-options [ generate-parser get-parser @@ -71,6 +78,9 @@ M: ebnf-sequence (generate-parser) ( ast -- id ) generate-parser get-parser ] map seq store-parser ; +M: ebnf-ensure-not (generate-parser) ( ast -- id ) + ebnf-ensure-not-group generate-parser get-parser ensure-not store-parser ; + M: ebnf-repeat0 (generate-parser) ( ast -- id ) ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ; @@ -136,6 +146,8 @@ DEFER: 'rhs' [ dup CHAR: ( = ] [ dup CHAR: ] = ] [ dup CHAR: [ = ] + [ dup CHAR: . = ] + [ dup CHAR: ! = ] } || not nip ] satisfy repeat1 [ >string ] action ; @@ -144,6 +156,10 @@ DEFER: 'rhs' #! and it represents the literal value of the identifier. 'identifier' [ ] action ; +: 'any-character' ( -- parser ) + #! A parser to match the symbol for any character match. + [ CHAR: . = ] satisfy [ drop ] action ; + : 'element' ( -- parser ) #! An element of a rule. It can be a terminal or a #! non-terminal but must not be followed by a "=". @@ -153,6 +169,7 @@ DEFER: 'rhs' [ 'non-terminal' , 'terminal' , + 'any-character' , ] choice* , "=" syntax ensure-not , ] seq* [ first ] action ; @@ -174,10 +191,20 @@ DEFER: 'choice' : 'optional' ( -- parser ) "[" [ ] "]" grouped ; +: 'ensure-not' ( -- parser ) + #! Parses the '!' syntax to ensure that + #! something that matches the following elements do + #! not exist in the parse stream. + [ + "!" syntax , + 'group' sp , + ] seq* [ first ] action ; + : 'sequence' ( -- parser ) #! A sequence of terminals and non-terminals, including #! groupings of those. [ + 'ensure-not' sp , 'element' sp , 'group' sp , 'repeat0' sp , From de4b699d98a7d14830989d90b51349e7eb98207f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 19 Mar 2008 02:43:23 -0500 Subject: [PATCH 071/886] Documentation update --- core/alien/alien-docs.factor | 7 ++--- core/alien/c-types/c-types-docs.factor | 32 ++++++++++++++++------- core/alien/compiler/compiler-tests.factor | 10 +++---- 3 files changed, 32 insertions(+), 17 deletions(-) diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 95b29ee50b..7bba9d7332 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -210,8 +210,9 @@ $nl 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" } "." @@ -290,7 +291,7 @@ $nl "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" } diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor index fe6873ac3a..8d2b03467b 100755 --- a/core/alien/c-types/c-types-docs.factor +++ b/core/alien/c-types/c-types-docs.factor @@ -158,6 +158,19 @@ HELP: define-out { $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 @@ -229,13 +242,11 @@ $nl { $subsection } { $subsection } { $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 } @@ -245,8 +256,6 @@ $nl { $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:" @@ -271,20 +280,25 @@ ARTICLE: "c-strings" "C strings" { $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 } "." +"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 } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches." $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 } ; +{ $subsection alien>u16-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 } "." ; 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:" diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index 7e2e23726b..f9dc426de1 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -330,11 +330,11 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; ! 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 +! cpu "arm" = [ +! [ "testing" ] [ +! "testing" callback-5a callback_test_1 +! ] unit-test +! ] unless : callback-6 "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; From 36c94f357c95791d16f618e7a7f552a65f1cc304 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 19 Mar 2008 02:43:36 -0500 Subject: [PATCH 072/886] Fix shaker's libc stripping --- extra/tools/deploy/shaker/strip-libc.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) mode change 100644 => 100755 extra/tools/deploy/shaker/strip-libc.factor diff --git a/extra/tools/deploy/shaker/strip-libc.factor b/extra/tools/deploy/shaker/strip-libc.factor old mode 100644 new mode 100755 index 898399b092..ba1436fd17 --- a/extra/tools/deploy/shaker/strip-libc.factor +++ b/extra/tools/deploy/shaker/strip-libc.factor @@ -1,10 +1,10 @@ USING: libc.private ; IN: libc -: malloc (malloc) ; +: malloc (malloc) check-ptr ; + +: realloc (realloc) check-ptr ; + +: calloc (calloc) check-ptr ; : free (free) ; - -: realloc (realloc) ; - -: calloc (calloc) ; From 82d54d37769a30663face16e7bbd6c800bee8171 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 01:18:09 +1300 Subject: [PATCH 073/886] EBNF syntax change [ ... ] is now ( ... )? { ... } is now ( ... )* Added ( ... )+ --- extra/peg/ebnf/ebnf-tests.factor | 4 ++-- extra/peg/ebnf/ebnf.factor | 34 +++++++++++++++++++++++--------- 2 files changed, 27 insertions(+), 11 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 86a7a454ed..6838bf3eca 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -83,7 +83,7 @@ IN: peg.ebnf.tests } } } [ - "one {(two | three) four}" 'choice' parse parse-result-ast + "one ((two | three) four)*" 'choice' parse parse-result-ast ] unit-test { @@ -95,7 +95,7 @@ IN: peg.ebnf.tests } } } [ - "one [ two ] three" 'choice' parse parse-result-ast + "one ( two )? three" 'choice' parse parse-result-ast ] unit-test { "foo" } [ diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 4dc096ecbd..59695998ce 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -12,6 +12,7 @@ TUPLE: ebnf-ensure-not group ; TUPLE: ebnf-choice options ; TUPLE: ebnf-sequence elements ; TUPLE: ebnf-repeat0 group ; +TUPLE: ebnf-repeat1 group ; TUPLE: ebnf-optional elements ; TUPLE: ebnf-rule symbol elements ; TUPLE: ebnf-action word ; @@ -24,6 +25,7 @@ C: ebnf-ensure-not C: ebnf-choice C: ebnf-sequence C: ebnf-repeat0 +C: ebnf-repeat1 C: ebnf-optional C: ebnf-rule C: ebnf-action @@ -84,6 +86,9 @@ M: ebnf-ensure-not (generate-parser) ( ast -- id ) M: ebnf-repeat0 (generate-parser) ( ast -- id ) ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ; +M: ebnf-repeat1 (generate-parser) ( ast -- id ) + ebnf-repeat1-group generate-parser get-parser repeat1 store-parser ; + M: ebnf-optional (generate-parser) ( ast -- id ) ebnf-optional-elements generate-parser get-parser optional store-parser ; @@ -176,20 +181,30 @@ DEFER: 'rhs' DEFER: 'choice' -: grouped ( begin quot end -- parser ) - #! Parse a group of choices, where the delimiter for the - #! group is specified by 'begin' and 'end'. The quotation - #! should produce the AST to be the result of the parser. - [ [ 'choice' sp ] delay swap action ] dip syntax-pack ; - +: grouped ( quot suffix -- parser ) + #! Parse a group of choices, with a suffix indicating + #! the type of group (repeat0, repeat1, etc) and + #! an quot that is the action that produces the AST. + "(" [ 'choice' sp ] delay ")" syntax-pack + swap 2seq + [ first ] rot compose action ; + : 'group' ( -- parser ) - "(" [ ] ")" grouped ; + #! A grouping with no suffix. Used for precedence. + [ ] [ + "*" token sp ensure-not , + "+" token sp ensure-not , + "?" token sp ensure-not , + ] seq* hide grouped ; : 'repeat0' ( -- parser ) - "{" [ ] "}" grouped ; + [ ] "*" syntax grouped ; + +: 'repeat1' ( -- parser ) + [ ] "+" syntax grouped ; : 'optional' ( -- parser ) - "[" [ ] "]" grouped ; + [ ] "?" syntax grouped ; : 'ensure-not' ( -- parser ) #! Parses the '!' syntax to ensure that @@ -208,6 +223,7 @@ DEFER: 'choice' 'element' sp , 'group' sp , 'repeat0' sp , + 'repeat1' sp , 'optional' sp , ] choice* repeat1 [ dup length 1 = [ first ] [ ] if From c0b7bdf823001f4389e7f13df86d05a16dba0822 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 01:25:57 +1300 Subject: [PATCH 074/886] Add *, + and ? to list of non-allowed ebnf identifier characteres --- extra/peg/ebnf/ebnf.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 59695998ce..b500d82e98 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -153,6 +153,9 @@ DEFER: 'rhs' [ dup CHAR: [ = ] [ dup CHAR: . = ] [ dup CHAR: ! = ] + [ dup CHAR: * = ] + [ dup CHAR: + = ] + [ dup CHAR: ? = ] } || not nip ] satisfy repeat1 [ >string ] action ; From 65fabeec11956cf7d2d7ddacd50b33b7d6e10823 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 02:16:30 +1300 Subject: [PATCH 075/886] remove => action and replace it with [[ code ]] in EBNF Previously the action had to be a factor word and could only appear at the end of a rule: : aword ( ast -- ast ) drop V{ 1 2 } ; aword EBNF> Now actions can appear anywhere after an element, and can be any factor code between [[ ... ]] delimiters: Unfortunately since this means the ebnf>quot code uses the equivalent of eval, it no longer compiles nicely since it can't be inferred. The generated parsers however do compile. --- extra/peg/ebnf/ebnf-tests.factor | 12 +++++++++++- extra/peg/ebnf/ebnf.factor | 25 ++++++++++++++----------- 2 files changed, 25 insertions(+), 12 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 6838bf3eca..63cec2f120 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -1,7 +1,7 @@ ! 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 compiler.units ; IN: peg.ebnf.tests { T{ ebnf-non-terminal f "abc" } } [ @@ -114,4 +114,14 @@ IN: peg.ebnf.tests "foo]" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol ] unit-test +{ V{ "a" "b" } } [ + "foo='a' 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast +] unit-test +{ V{ 1 "b" } } [ + "foo='a' [[ drop 1 ]] 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast +] unit-test + +{ V{ 1 2 } } [ + "foo='a' [[ drop 1 ]] 'b' [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast +] unit-test \ No newline at end of file diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index b500d82e98..2e0740663a 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel parser words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg - peg.parsers unicode.categories multiline combinators.lib ; + peg.parsers unicode.categories multiline combinators.lib + splitting ; IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; @@ -15,7 +16,7 @@ TUPLE: ebnf-repeat0 group ; TUPLE: ebnf-repeat1 group ; TUPLE: ebnf-optional elements ; TUPLE: ebnf-rule symbol elements ; -TUPLE: ebnf-action word ; +TUPLE: ebnf-action code ; TUPLE: ebnf rules ; C: ebnf-non-terminal @@ -98,7 +99,7 @@ M: ebnf-rule (generate-parser) ( ast -- id ) swap [ parsers get set-nth ] keep ; M: ebnf-action (generate-parser) ( ast -- id ) - ebnf-action-word search 1quotation + ebnf-action-code string-lines parse-lines last-parser get get-parser swap action store-parser ; M: vector (generate-parser) ( ast -- id ) @@ -237,20 +238,22 @@ DEFER: 'choice' dup length 1 = [ first ] [ ] if ] action ; -: 'action' ( -- parser ) +: 'factor-code' ( -- parser ) [ - "=>" token hide , - [ - [ blank? ] satisfy ensure-not , - [ drop t ] satisfy , - ] seq* [ first ] action repeat1 [ >string ] action sp , - ] seq* [ first ] action ; + "]]" token ensure-not , + [ drop t ] satisfy , + ] seq* [ first ] action repeat0 [ >string ] action ; + +: 'action' ( -- parser ) + "[[" 'factor-code' "]]" syntax-pack [ ] action ; : 'rhs' ( -- parser ) [ 'choice' , 'action' sp optional , - ] seq* ; + ] seq* repeat1 [ + dup length 1 = [ first ] [ ] if + ] action ; : 'rule' ( -- parser ) [ From 92d8140d87cff4015eb9d396296db0d015d7e0dd Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 03:05:40 +1300 Subject: [PATCH 076/886] Change ebnf-action to properly nest with attached parser This allows removal of last-parser hack. Syntax of EBNF changes though. Now an action must attach to a group: --- extra/peg/ebnf/ebnf-tests.factor | 18 ++++-------- extra/peg/ebnf/ebnf.factor | 49 ++++++++++++++------------------ 2 files changed, 27 insertions(+), 40 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 63cec2f120..8846a9c94c 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -15,11 +15,8 @@ IN: peg.ebnf.tests { 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" } } } } } [ @@ -29,11 +26,8 @@ IN: peg.ebnf.tests { 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" } } } } } [ @@ -119,9 +113,9 @@ IN: peg.ebnf.tests ] unit-test { V{ 1 "b" } } [ - "foo='a' [[ drop 1 ]] 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast + "foo=('a')[[ drop 1 ]] 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast ] unit-test { V{ 1 2 } } [ - "foo='a' [[ drop 1 ]] 'b' [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast + "foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast ] unit-test \ No newline at end of file diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 2e0740663a..e2c2dd5006 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -16,7 +16,7 @@ TUPLE: ebnf-repeat0 group ; TUPLE: ebnf-repeat1 group ; TUPLE: ebnf-optional elements ; TUPLE: ebnf-rule symbol elements ; -TUPLE: ebnf-action code ; +TUPLE: ebnf-action parser code ; TUPLE: ebnf rules ; C: ebnf-non-terminal @@ -34,12 +34,10 @@ C: ebnf SYMBOL: parsers SYMBOL: non-terminals -SYMBOL: last-parser : reset-parser-generation ( -- ) V{ } clone parsers set - H{ } clone non-terminals set - f last-parser set ; + H{ } clone non-terminals set ; : store-parser ( parser -- number ) parsers get [ push ] keep length 1- ; @@ -57,7 +55,7 @@ SYMBOL: last-parser GENERIC: (generate-parser) ( ast -- id ) : generate-parser ( ast -- id ) - (generate-parser) dup last-parser set ; + (generate-parser) ; M: ebnf-terminal (generate-parser) ( ast -- id ) ebnf-terminal-symbol token sp store-parser ; @@ -99,15 +97,12 @@ M: ebnf-rule (generate-parser) ( ast -- id ) swap [ parsers get set-nth ] keep ; M: ebnf-action (generate-parser) ( ast -- id ) - ebnf-action-code string-lines parse-lines - last-parser get get-parser swap action store-parser ; + [ ebnf-action-parser generate-parser get-parser ] keep + ebnf-action-code string-lines parse-lines action store-parser ; M: vector (generate-parser) ( ast -- id ) [ generate-parser ] map peek ; -M: f (generate-parser) ( ast -- id ) - drop last-parser get ; - M: ebnf (generate-parser) ( ast -- id ) ebnf-rules [ generate-parser @@ -199,6 +194,7 @@ DEFER: 'choice' "*" token sp ensure-not , "+" token sp ensure-not , "?" token sp ensure-not , + "[[" token sp ensure-not , ] seq* hide grouped ; : 'repeat0' ( -- parser ) @@ -210,6 +206,19 @@ DEFER: 'choice' : 'optional' ( -- parser ) [ ] "?" syntax grouped ; +: 'factor-code' ( -- parser ) + [ + "]]" token ensure-not , + [ drop t ] satisfy , + ] seq* [ first ] action repeat0 [ >string ] action ; + +: 'action' ( -- parser ) + [ + "(" [ 'choice' sp ] delay ")" syntax-pack , + "[[" 'factor-code' "]]" syntax-pack , + ] seq* [ first2 ] action ; + + : 'ensure-not' ( -- parser ) #! Parses the '!' syntax to ensure that #! something that matches the following elements do @@ -229,6 +238,7 @@ DEFER: 'choice' 'repeat0' sp , 'repeat1' sp , 'optional' sp , + 'action' sp , ] choice* repeat1 [ dup length 1 = [ first ] [ ] if ] action ; @@ -237,29 +247,12 @@ DEFER: 'choice' 'sequence' sp "|" token sp list-of [ dup length 1 = [ first ] [ ] if ] action ; - -: 'factor-code' ( -- parser ) - [ - "]]" token ensure-not , - [ drop t ] satisfy , - ] seq* [ first ] action repeat0 [ >string ] action ; - -: 'action' ( -- parser ) - "[[" 'factor-code' "]]" syntax-pack [ ] action ; - -: 'rhs' ( -- parser ) - [ - 'choice' , - 'action' sp optional , - ] seq* repeat1 [ - dup length 1 = [ first ] [ ] if - ] action ; : 'rule' ( -- parser ) [ 'non-terminal' [ ebnf-non-terminal-symbol ] action , "=" syntax , - 'rhs' , + 'choice' , ] seq* [ first2 ] action ; : 'ebnf' ( -- parser ) From 97b58580a7a0bb633d88c1f7855ba3ad7a2cbf03 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 03:30:53 +1300 Subject: [PATCH 077/886] Add expression evaluator example for EBNF --- extra/peg/expr/authors.txt | 1 + extra/peg/expr/expr.factor | 30 ++++++++++++++++++++++++++++++ extra/peg/expr/summary.txt | 1 + extra/peg/expr/tags.txt | 1 + 4 files changed, 33 insertions(+) create mode 100644 extra/peg/expr/authors.txt create mode 100644 extra/peg/expr/expr.factor create mode 100644 extra/peg/expr/summary.txt create mode 100644 extra/peg/expr/tags.txt diff --git a/extra/peg/expr/authors.txt b/extra/peg/expr/authors.txt new file mode 100644 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/peg/expr/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/peg/expr/expr.factor b/extra/peg/expr/expr.factor new file mode 100644 index 0000000000..ed13ac0e50 --- /dev/null +++ b/extra/peg/expr/expr.factor @@ -0,0 +1,30 @@ +! 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 + +: operator-fold ( lhs seq -- value ) + #! Perform a fold of a lhs, followed by a sequence of pairs being + #! { operator rhs } in to a tree structure of the correct precedence. + swap [ first2 swap call ] reduce ; + +number ]] + +value = number | ("(" expr ")") [[ second ]] +product = (value ((times | divide) value)*) [[ first2 operator-fold ]] +sum = (product ((add | subtract) product)*) [[ first2 operator-fold ]] +expr = sum +EBNF> + +: eval-expr ( string -- number ) + expr parse parse-result-ast ; \ No newline at end of file diff --git a/extra/peg/expr/summary.txt b/extra/peg/expr/summary.txt new file mode 100644 index 0000000000..6c3c140b2b --- /dev/null +++ b/extra/peg/expr/summary.txt @@ -0,0 +1 @@ +Simple expression evaluator using EBNF diff --git a/extra/peg/expr/tags.txt b/extra/peg/expr/tags.txt new file mode 100644 index 0000000000..9da56880c0 --- /dev/null +++ b/extra/peg/expr/tags.txt @@ -0,0 +1 @@ +parsing From 3d43c0350eaa1a0ab88dd14cdd9bd6dd8499d75a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 19 Mar 2008 13:26:39 -0500 Subject: [PATCH 078/886] Fix USING: in alien.factor --- core/alien/alien.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/alien/alien.factor b/core/alien/alien.factor index ca35cb3696..fc89586b68 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -2,7 +2,7 @@ ! 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 ; +arrays ; IN: alien ! Some predicate classes used by the compiler for optimization From 005de2515629b53e1c1c823798cfdb0f791d5f67 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 19 Mar 2008 14:25:53 -0500 Subject: [PATCH 079/886] Cocoa UI cleanup --- extra/cocoa/windows/windows.factor | 3 ++- extra/tools/walker/walker.factor | 4 +--- extra/ui/cocoa/cocoa.factor | 35 +++++++++++++++++++----------- extra/ui/cocoa/views/views.factor | 9 +++++++- extra/ui/windows/windows.factor | 16 -------------- 5 files changed, 33 insertions(+), 34 deletions(-) diff --git a/extra/cocoa/windows/windows.factor b/extra/cocoa/windows/windows.factor index b45acaf852..74a181f9a2 100755 --- a/extra/cocoa/windows/windows.factor +++ b/extra/cocoa/windows/windows.factor @@ -30,7 +30,8 @@ IN: cocoa.windows : ( view rect -- window ) [ 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 diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index 610d3db0a3..6ef5309214 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -30,8 +30,6 @@ DEFER: start-walker-thread 2dup start-walker-thread ] if* ; -USING: io.streams.c prettyprint ; - : show-walker ( -- thread ) get-walker-thread [ show-walker-hook get call ] keep ; @@ -40,7 +38,7 @@ USING: io.streams.c prettyprint ; { { [ dup continuation? ] [ (continue) ] } { [ dup quotation? ] [ call ] } - { [ dup not ] [ "Single stepping abandoned" throw ] } + { [ dup not ] [ "Single stepping abandoned" rethrow ] } } cond ; : break ( -- ) diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 572e798bd0..79b7041dcb 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -1,4 +1,4 @@ -! 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 @@ -8,6 +8,10 @@ ui.clipboards ui.gadgets ui.gadgets.worlds ui.cocoa.views core-foundation threads ; IN: ui.cocoa +TUPLE: handle view window ; + +C: handle + TUPLE: cocoa-ui-backend ; SYMBOL: stop-after-last-window? @@ -47,27 +51,30 @@ M: pasteboard set-clipboard-contents dup rot world>NSRect dup install-window-delegate over -> release - 2array + ] keep set-world-handle ; M: cocoa-ui-backend set-title ( string world -- ) - world-handle second swap -> setTitle: ; + world-handle handle-window swap -> 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 ; @@ -75,27 +82,29 @@ M: cocoa-ui-backend fullscreen* ( world -- ? ) 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 diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor index a965e8a30c..5b975f40de 100755 --- a/extra/ui/cocoa/views/views.factor +++ b/extra/ui/cocoa/views/views.factor @@ -313,6 +313,7 @@ CLASS: { { "dealloc" "void" { "id" "SEL" } [ drop + dup unregister-window dup remove-observer SUPER-> dealloc ] @@ -349,7 +350,13 @@ CLASS: { { "windowShouldClose:" "bool" { "id" "SEL" "id" } [ - 2nip -> contentView window ungraft t + 3drop t + ] +} + +{ "windowWillClose:" "void" { "id" "SEL" "id" } + [ + 2nip -> object -> contentView window ungraft ] } ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 0c9c23cf76..f47a82275b 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -376,22 +376,6 @@ SYMBOL: trace-messages? : 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 ] } From 3591ed402d2a0bda54c548471e83277746f5f7da Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 19 Mar 2008 14:39:08 -0500 Subject: [PATCH 080/886] Simplify vocab.loader even further --- core/bootstrap/primitives.factor | 1 + core/vocabs/loader/loader-docs.factor | 2 - core/vocabs/loader/loader-tests.factor | 10 ++-- core/vocabs/loader/loader.factor | 64 +++++++++-------------- core/vocabs/vocabs-docs.factor | 9 +--- core/vocabs/vocabs.factor | 21 ++++---- extra/help/markup/markup.factor | 2 +- extra/tools/deploy/deploy-tests.factor | 4 ++ extra/tools/vocabs/browser/browser.factor | 2 +- extra/tools/vocabs/vocabs.factor | 48 ++++++++--------- 10 files changed, 69 insertions(+), 94 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 0b686e3c7f..e407bfd143 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -30,6 +30,7 @@ crossref off "syntax" vocab vocab-words bootstrap-syntax set H{ } clone dictionary set H{ } clone changed-words set +H{ } clone root-cache set ! Trivial recompile hook. We don't want to touch the code heap ! during stage1 bootstrap, it would just waste time. diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index c7652c34c7..c0542f7b96 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -43,8 +43,6 @@ HELP: find-vocab-root { $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 } "." } diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 015f54540d..0519096128 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -13,15 +13,15 @@ debugger compiler.units tools.vocabs ; ] 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-files + "kernel" vocab-files 3array all-equal? ] unit-test @@ -36,7 +36,7 @@ IN: vocabs.loader.tests [ { 3 3 3 } ] [ "vocabs.loader.test.2" run "vocabs.loader.test.2" vocab run - "vocabs.loader.test.2" f run + "vocabs.loader.test.2" run 3array ] unit-test @@ -115,7 +115,7 @@ IN: vocabs.loader.tests [ 3 ] [ "count-me" get-global ] unit-test [ { "resource:core/kernel/kernel.factor" 1 } ] -[ "kernel" f where ] unit-test +[ "kernel" where ] unit-test [ { "resource:core/kernel/kernel.factor" 1 } ] [ "kernel" vocab where ] unit-test diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 96193ef664..9833b2834f 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -23,15 +23,6 @@ V{ [ >r dup peek r> append add ] 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? @@ -39,14 +30,23 @@ V{ 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 ; -M: string vocab-root - vocab dup [ vocab-root ] when ; +: vocab-path+ ( vocab path -- newpath ) + swap find-vocab-root dup [ swap path+ ] [ 2drop f ] if ; -M: vocab-link vocab-root - vocab-link-root ; +: 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+ ; SYMBOL: load-help? @@ -56,7 +56,7 @@ 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? ; @@ -70,18 +70,9 @@ SYMBOL: load-help? 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 -- ) @@ -104,22 +95,17 @@ SYMBOL: blacklist GENERIC: (load-vocab) ( name -- ) M: vocab (load-vocab) - dup update-root - - 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: string (load-vocab) - ! ".private" ?tail drop - dup find-vocab-root >vocab-link (load-vocab) ; + [ + dup vocab-source-loaded? [ dup load-source ] unless + dup vocab-docs-loaded? [ dup load-docs ] unless + drop + ] [ [ swap add-to-blacklist ] keep rethrow ] recover ; M: vocab-link (load-vocab) - dup vocab-name swap vocab-root dup - [ create-vocab-with-root (load-vocab) ] [ 2drop ] if ; + vocab-name create-vocab (load-vocab) ; + +M: string (load-vocab) + create-vocab (load-vocab) ; [ [ diff --git a/core/vocabs/vocabs-docs.factor b/core/vocabs/vocabs-docs.factor index f16a33f0d5..0d55499620 100755 --- a/core/vocabs/vocabs-docs.factor +++ b/core/vocabs/vocabs-docs.factor @@ -16,7 +16,6 @@ $nl { $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:" @@ -50,10 +49,6 @@ HELP: vocab-name { $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." } ; @@ -101,11 +96,11 @@ HELP: child-vocabs } ; 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 } "." } ; diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 9d281c864b..807e08f73b 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -92,10 +92,10 @@ SYMBOL: load-vocab-hook ! ( name -- ) : child-vocabs ( vocab -- seq ) vocab-name vocabs [ child-vocab? ] with subset ; -TUPLE: vocab-link name root ; +TUPLE: vocab-link name ; -: ( name root -- vocab-link ) - [ dup vocab-root ] unless* vocab-link construct-boa ; +: ( name -- vocab-link ) + vocab-link construct-boa ; M: vocab-link equal? over vocab-link? @@ -106,17 +106,14 @@ M: vocab-link hashcode* M: vocab-link vocab-name vocab-link-name ; -GENERIC# >vocab-link 1 ( name root -- vocab ) - -M: vocab >vocab-link drop ; - -M: vocab-link >vocab-link drop ; - -M: string >vocab-link - over vocab dup [ 2nip ] [ drop ] if ; - UNION: vocab-spec vocab vocab-link ; +GENERIC: >vocab-link ( name -- vocab ) + +M: vocab-spec >vocab-link ; + +M: string >vocab-link dup vocab [ ] [ ] ?if ; + : forget-vocab ( vocab -- ) dup words forget-all vocab-name dictionary get delete-at ; diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 7cfe384bde..47a40d6948 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -159,7 +159,7 @@ M: f print-element drop ; [ first ($long-link) ] ($subsection) ; : ($vocab-link) ( text vocab -- ) - dup vocab-root >vocab-link write-link ; + >vocab-link write-link ; : $vocab-subsection ( element -- ) [ diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 6d3385d0a4..c7a97e7787 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -26,6 +26,10 @@ tools.deploy.backend math sequences io.launcher arrays ; [ ] [ "hello-ui" shake-and-bake ] unit-test +[ "staging.math-compiler-ui-strip.image" ] [ + "hello-ui" deploy-config [ staging-image-name ] bind +] unit-test + [ t ] [ 2000000 small-enough? ] unit-test diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor index 2c66305d47..06eba5f65c 100755 --- a/extra/tools/vocabs/browser/browser.factor +++ b/extra/tools/vocabs/browser/browser.factor @@ -127,7 +127,7 @@ C: vocab-author : $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 diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 82c411cbfb..2f2e834808 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -6,29 +6,27 @@ memoize inspector sorting splitting combinators source-files io debugger continuations compiler.errors init io.crc32 ; IN: tools.vocabs -: vocab-tests-file, ( vocab -- ) - dup "-tests.factor" vocab-dir+ vocab-path+ - dup resource-exists? [ , ] [ drop ] if ; +: vocab-tests-file ( vocab -- path ) + dup "-tests.factor" vocab-dir+ vocab-path+ dup + [ dup resource-exists? [ drop f ] unless ] [ drop f ] if ; -: vocab-tests-dir, ( vocab -- ) - dup vocab-dir "tests" path+ vocab-path+ - dup resource-exists? [ - dup ?resource-path directory keys - [ ".factor" tail? ] subset - [ path+ , ] with each - ] [ drop ] if ; +: vocab-tests-dir ( vocab -- paths ) + dup vocab-dir "tests" path+ vocab-path+ dup [ + dup resource-exists? [ + dup ?resource-path directory keys + [ ".factor" tail? ] subset + [ path+ ] with map + ] [ drop f ] if + ] [ drop f ] if ; : vocab-tests ( vocab -- tests ) - dup vocab-root dup [ - [ - >vocab-link dup - vocab-tests-file, - vocab-tests-dir, - ] { } make - ] [ 2drop f ] if ; + [ + dup vocab-tests-file [ , ] when* + vocab-tests-dir [ % ] when* + ] { } make ; : vocab-files ( vocab -- seq ) - dup find-vocab-root >vocab-link [ + [ dup vocab-source-path [ , ] when* dup vocab-docs-path [ , ] when* vocab-tests % @@ -53,12 +51,8 @@ IN: tools.vocabs : modified-docs ( vocabs -- seq ) [ vocab-docs-path ] modified ; -: update-roots ( vocabs -- ) - [ dup find-vocab-root swap vocab set-vocab-root ] each ; - : to-refresh ( prefix -- modified-sources modified-docs ) child-vocabs - dup update-roots dup modified-sources swap modified-docs ; : vocab-heading. ( vocab -- ) @@ -180,7 +174,7 @@ M: vocab-link summary vocab-summary ; : vocabs-in-dir ( root name -- ) dupd (all-child-vocabs) [ - 2dup vocab-dir? [ 2dup swap >vocab-link , ] when + 2dup vocab-dir? [ dup >vocab-link , ] when vocabs-in-dir ] with each ; @@ -233,7 +227,7 @@ MEMO: all-vocabs-seq ( -- seq ) : unrooted-child-vocabs ( prefix -- seq ) dup empty? [ CHAR: . add ] unless vocabs - [ vocab-root not ] subset + [ find-vocab-root not ] subset [ vocab-name swap ?head CHAR: . rot member? not and ] with subset @@ -241,10 +235,9 @@ MEMO: all-vocabs-seq ( -- seq ) : all-child-vocabs ( prefix -- assoc ) vocab-roots get [ - over dupd dupd (all-child-vocabs) - swap [ >vocab-link ] curry map + dup pick (all-child-vocabs) [ >vocab-link ] map ] { } map>assoc - f rot unrooted-child-vocabs 2array add ; + swap unrooted-child-vocabs f swap 2array add ; : all-child-vocabs-seq ( prefix -- assoc ) vocab-roots get swap [ @@ -262,6 +255,7 @@ MEMO: all-authors ( -- seq ) all-vocabs-seq [ vocab-authors ] map>set ; : reset-cache ( -- ) + root-cache get-global clear-assoc \ (vocab-file-contents) reset-memoized \ all-vocabs-seq reset-memoized \ all-authors reset-memoized From 5904d3fffae0c1fed2797df1bde32f956130e32d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 19 Mar 2008 15:24:49 -0500 Subject: [PATCH 081/886] Fix set-timeout with dan's new encoding stuff --- core/classes/classes-tests.factor | 12 +++++++----- core/io/encodings/encodings.factor | 26 ++++++++++++++------------ extra/io/timeouts/timeouts.factor | 6 +++++- extra/tools/deploy/deploy-tests.factor | 3 ++- 4 files changed, 28 insertions(+), 19 deletions(-) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 7d43ee905a..f97f088845 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -1,6 +1,6 @@ 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 ; IN: classes.tests @@ -63,10 +63,6 @@ UNION: c a b ; 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 ; @@ -180,6 +176,8 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ; [ 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 @@ -224,3 +222,7 @@ MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1 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 diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 4cd43ef455..03ea2262a8 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -14,19 +14,26 @@ GENERIC: encode-char ( char stream encoding -- ) GENERIC: ( stream decoding -- newstream ) -GENERIC: ( stream encoding -- newstream ) - : replacement-char HEX: fffd ; -! Decoding - - ( stream encoding -- newstream ) + +TUPLE: encoder stream code ; + +TUPLE: encode-error ; + +: encode-error ( -- * ) \ encode-error construct-empty throw ; + +! Decoding + + construct-empty ; M: tuple f decoder construct-boa ; @@ -101,12 +108,6 @@ M: decoder stream-readln ( stream -- str ) M: decoder dispose decoder-stream dispose ; ! Encoding - -TUPLE: encode-error ; - -: encode-error ( -- * ) \ encode-error construct-empty throw ; - -TUPLE: encoder stream code ; M: tuple-class construct-empty ; M: tuple encoder construct-boa ; @@ -132,6 +133,7 @@ INSTANCE: encoder plain-writer : redecode ( stream encoding -- newstream ) over decoder? [ >r decoder-stream r> ] when ; + PRIVATE> : ( stream-in stream-out encoding -- duplex ) diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor index ef660a6f0d..f1031e98e2 100755 --- a/extra/io/timeouts/timeouts.factor +++ b/extra/io/timeouts/timeouts.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel calendar alarms io.streams.duplex ; +USING: kernel calendar alarms io.streams.duplex io.encodings ; IN: io.timeouts ! Won't need this with new slot accessors @@ -12,6 +12,10 @@ M: duplex-stream set-timeout duplex-stream-in set-timeout duplex-stream-out set-timeout ; +M: decoder set-timeout decoder-stream set-timeout ; + +M: encoder set-timeout encoder-stream set-timeout ; + GENERIC: timed-out ( obj -- ) M: object timed-out drop ; diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index c7a97e7787..3b88d14fb3 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -1,6 +1,7 @@ IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config -tools.deploy.backend math sequences io.launcher arrays ; +tools.deploy.backend math sequences io.launcher arrays +namespaces ; : shake-and-bake ( vocab -- ) "." resource-path [ From 40aab45282ead3651f45ebce0d064352276f95b8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 19 Mar 2008 16:16:35 -0500 Subject: [PATCH 082/886] add do-while and use it in generate --- extra/combinators/lib/lib.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 7c93f805cd..6f1fbbe2c0 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -8,13 +8,6 @@ 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 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -165,3 +158,10 @@ MACRO: construct-slots ( assoc tuple-class -- tuple ) : 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 ; From b3527a17df070ccb0212e52bfab214ee7ecc5df0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 19 Mar 2008 16:18:03 -0500 Subject: [PATCH 083/886] redo random/ --- .../blum-blum-shub/blum-blum-shub.factor | 36 ++++++ extra/random/dummy/dummy.factor | 11 ++ .../random/{ => mersenne-twister}/authors.txt | 0 .../mersenne-twister-docs.factor.bak} | 10 +- .../mersenne-twister-tests.factor | 30 +++++ .../mersenne-twister/mersenne-twister.factor | 80 +++++++++++++ .../random/{ => mersenne-twister}/summary.txt | 0 extra/random/random-tests.factor | 15 --- extra/random/random.factor | 112 ++++-------------- extra/random/unix/unix.factor | 22 ++++ extra/random/windows/windows.factor | 3 + 11 files changed, 209 insertions(+), 110 deletions(-) create mode 100644 extra/random/blum-blum-shub/blum-blum-shub.factor create mode 100644 extra/random/dummy/dummy.factor rename extra/random/{ => mersenne-twister}/authors.txt (100%) rename extra/random/{random-docs.factor => mersenne-twister/mersenne-twister-docs.factor.bak} (78%) create mode 100644 extra/random/mersenne-twister/mersenne-twister-tests.factor create mode 100755 extra/random/mersenne-twister/mersenne-twister.factor rename extra/random/{ => mersenne-twister}/summary.txt (100%) delete mode 100644 extra/random/random-tests.factor mode change 100755 => 100644 extra/random/random.factor create mode 100644 extra/random/unix/unix.factor create mode 100644 extra/random/windows/windows.factor diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor new file mode 100644 index 0000000000..e1ba48281a --- /dev/null +++ b/extra/random/blum-blum-shub/blum-blum-shub.factor @@ -0,0 +1,36 @@ +USING: kernel math sequences namespaces +math.miller-rabin combinators.cleave combinators.lib +math.functions new-slots accessors random ; +IN: random.blum-blum-shub + +! TODO: take (log log M) bits instead of 1 bit +! Blum Blum Shub, M = pq +TUPLE: blum-blum-shub x n ; + +C: blum-blum-shub + +: generate-bbs-primes ( numbits -- p q ) + #! two primes congruent to 3 (mod 4) + [ [ random-prime ] curry [ 4 mod 3 = ] generate ] dup bi ; + +IN: crypto +: ( numbits -- blum-blum-shub ) + #! returns a Blum-Blum-Shub tuple + generate-bbs-primes * + [ find-relative-prime ] keep + blum-blum-shub construct-boa ; + +! 256 make-bbs blum-blum-shub set-global + +: next-bbs-bit ( bbs -- bit ) + #! x = x^2 mod n, return low bit of calculated x + [ [ x>> 2 ] [ n>> ] bi ^mod ] + [ [ >>x ] keep x>> 1 bitand ] bi ; + +IN: crypto +! : random ( n -- n ) + ! ! #! Cryptographically secure random number using Blum-Blum-Shub 256 + ! [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ; + +M: blum-blum-shub random-32 ( bbs -- r ) + ; diff --git a/extra/random/dummy/dummy.factor b/extra/random/dummy/dummy.factor new file mode 100644 index 0000000000..af6e2365bb --- /dev/null +++ b/extra/random/dummy/dummy.factor @@ -0,0 +1,11 @@ +USING: kernel random math new-slots accessors ; +IN: random.dummy + +TUPLE: random-dummy i ; +C: random-dummy + +M: random-dummy seed-random ( seed obj -- ) + (>>i) ; + +M: random-dummy random-32 ( obj -- r ) + [ dup 1+ ] change-i drop ; diff --git a/extra/random/authors.txt b/extra/random/mersenne-twister/authors.txt similarity index 100% rename from extra/random/authors.txt rename to extra/random/mersenne-twister/authors.txt diff --git a/extra/random/random-docs.factor b/extra/random/mersenne-twister/mersenne-twister-docs.factor.bak similarity index 78% rename from extra/random/random-docs.factor rename to extra/random/mersenne-twister/mersenne-twister-docs.factor.bak index 1d8334ab31..981b206b29 100644 --- a/extra/random/random-docs.factor +++ b/extra/random/mersenne-twister/mersenne-twister-docs.factor.bak @@ -1,17 +1,17 @@ USING: help.markup help.syntax math ; -IN: random +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 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: 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" } } diff --git a/extra/random/mersenne-twister/mersenne-twister-tests.factor b/extra/random/mersenne-twister/mersenne-twister-tests.factor new file mode 100644 index 0000000000..afd9d085b6 --- /dev/null +++ b/extra/random/mersenne-twister/mersenne-twister-tests.factor @@ -0,0 +1,30 @@ +USING: kernel math random namespaces random.mersenne-twister +sequences tools.test ; +IN: random.mersenne-twister.tests +USE: tools.walker + +: 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 r> with-random ; + +[ f ] [ 1234 [ make-100-randoms make-100-randoms = ] test-rng ] unit-test + +[ 1333075495 ] [ + 0 [ 1000 [ drop \ random get random-32 drop ] each \ random get random-32 ] test-rng +] unit-test + +[ 1575309035 ] [ + 0 [ 10000 [ drop \ random get random-32 drop ] each \ random 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 diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor new file mode 100755 index 0000000000..79101c083e --- /dev/null +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -0,0 +1,80 @@ +! 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 new-slots accessors +math.ranges combinators.cleave circular random ; +IN: random.mersenne-twister + += [ - ] [ drop ] if ; inline +: mt-wrap ( x -- y ) mt-n wrap ; inline + +: set-generated ( mt y from-elt to -- ) + >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi + r> bitxor bitxor r> new-set-nth drop ; inline + +: calculate-y ( mt y1 y2 -- y ) + >r over r> + [ new-nth mt-hi ] [ new-nth mt-lo ] 2bi* bitor ; inline + +: (mt-generate) ( mt-seq n -- y to from-elt ) + [ dup 1+ mt-wrap calculate-y ] + [ mt-m + mt-wrap new-nth ] + [ nip ] 2tri ; + +: mt-generate ( mt -- ) + [ seq>> mt-n [ dupd (mt-generate) set-generated ] with each ] + [ 0 >>i drop ] bi ; + +: init-mt-first ( seed -- seq ) + >r mt-n 0 r> + HEX: ffffffff bitand 0 new-set-nth ; + +: init-mt-formula ( seq i -- f(seq[i]) ) + tuck new-nth dup -30 shift bitxor 1812433253 * + + 1+ HEX: ffffffff bitand ; + +: init-mt-rest ( seq -- ) + mt-n 1- [0,b) [ + dupd [ init-mt-formula ] keep 1+ new-set-nth drop + ] with each ; + +: init-mt-seq ( seed -- seq ) + init-mt-first dup init-mt-rest ; + +: 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> + +: ( seed -- obj ) + init-mt-seq 0 mersenne-twister construct-boa + dup mt-generate ; + +M: mersenne-twister seed-random ( mt seed -- ) + init-mt-seq >>seq drop ; + +M: mersenne-twister random-32 ( mt -- r ) + dup [ seq>> ] [ i>> ] bi + dup mt-n < [ drop 0 pick mt-generate ] unless + new-nth mt-temper + swap [ 1+ ] change-i drop ; + +[ millis \ random set-global ] "random" add-init-hook diff --git a/extra/random/summary.txt b/extra/random/mersenne-twister/summary.txt similarity index 100% rename from extra/random/summary.txt rename to extra/random/mersenne-twister/summary.txt diff --git a/extra/random/random-tests.factor b/extra/random/random-tests.factor deleted file mode 100644 index d431e57d01..0000000000 --- a/extra/random/random-tests.factor +++ /dev/null @@ -1,15 +0,0 @@ -USING: kernel math random namespaces sequences tools.test ; -IN: random.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 ; - -[ 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 diff --git a/extra/random/random.factor b/extra/random/random.factor old mode 100755 new mode 100644 index db2aacd2b0..bbf54e21eb --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -1,107 +1,39 @@ -! 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 ; IN: random - mersenne-twister +: (random-bytes) ( tuple n -- byte-array ) + [ drop random-32 ] with map >c-uint-array ; -: mt-n 624 ; inline -: mt-m 397 ; inline -: mt-a HEX: 9908b0df ; inline -: mt-hi HEX: 80000000 ; inline -: mt-lo HEX: 7fffffff ; inline +DEFER: random -SYMBOL: mt +: random-bytes ( n -- r ) + [ + 4 /mod zero? [ 1+ ] unless + \ random get swap (random-bytes) + ] keep head ; -: 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 - -: 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 - -: mt-y ( y1 y2 -- y ) - mt-nth mt-lo bitand - >r mt-nth mt-hi bitand r> bitor ; inline - -: mod* ( x n -- y ) - #! no floating point - 2dup >= [ - ] [ drop ] if ; inline - -: (mt-generate) ( n -- y n n+(mt-m) ) - dup [ 1+ 624 mod* mt-y ] keep [ mt-m + 624 mod* ] keep ; - -: mt-generate ( -- ) - mt-n [ (mt-generate) set-mt-ith ] each - 0 mt get set-mersenne-twister-i ; - -: init-mt-first ( seed -- seq ) - >r mt-n 0 r> - HEX: ffffffff bitand 0 pick set-nth ; - -: init-mt-formula ( seq i -- f(seq[i]) ) - dup rot nth dup -30 shift bitxor - 1812433253 * + HEX: ffffffff bitand 1+ ; inline - -: 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 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-bits ( n -- r ) 2^ random ; : 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 +: with-random ( tuple quot -- ) + \ random swap with-variable ; inline diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor new file mode 100644 index 0000000000..f41a3ae0e8 --- /dev/null +++ b/extra/random/unix/unix.factor @@ -0,0 +1,22 @@ +USING: alien.c-types io io.files io.nonblocking kernel +namespaces random io.encodings.binary singleton ; +IN: random.unix + +SINGLETON: unix-random + +: file-read-unbuffered ( n path -- bytes ) + over default-buffer-size [ + binary [ read ] with-stream + ] with-variable ; + +M: unix-random os-crypto-random-bytes ( n -- byte-array ) + "/dev/random" file-read-unbuffered ; + +M: unix-random os-random-bytes ( n -- byte-array ) + "/dev/urandom" file-read-unbuffered ; + +M: unix-random os-crypto-random-32 ( -- r ) + 4 os-crypto-random-bytes *uint ; + +M: unix-random os-random-32 ( -- r ) + 4 os-random-bytes *uint ; diff --git a/extra/random/windows/windows.factor b/extra/random/windows/windows.factor new file mode 100644 index 0000000000..8b3c1012c8 --- /dev/null +++ b/extra/random/windows/windows.factor @@ -0,0 +1,3 @@ +IN: random.windows + +! M: windows-io From 5296c907d909be2f73176356485427bdfdc72d51 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 19 Mar 2008 16:19:00 -0500 Subject: [PATCH 084/886] remove random-bits --- extra/math/miller-rabin/miller-rabin.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor index 3985906b32..ea7f02829d 100755 --- a/extra/math/miller-rabin/miller-rabin.factor +++ b/extra/math/miller-rabin/miller-rabin.factor @@ -19,8 +19,6 @@ SYMBOL: trials : 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 ) From 9c74ba2f2f4b6b090cfe0ab6adee3adda83b51ee Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 19 Mar 2008 16:19:15 -0500 Subject: [PATCH 085/886] remove extra crypto file --- extra/crypto/blum-blum-shub.factor | 36 ------------------------------ 1 file changed, 36 deletions(-) delete mode 100644 extra/crypto/blum-blum-shub.factor diff --git a/extra/crypto/blum-blum-shub.factor b/extra/crypto/blum-blum-shub.factor deleted file mode 100644 index a1c196d08e..0000000000 --- a/extra/crypto/blum-blum-shub.factor +++ /dev/null @@ -1,36 +0,0 @@ -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 ; - -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 ; - From cd4f2028cda71711f1733ce4b5395b816968c625 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 19 Mar 2008 16:19:37 -0500 Subject: [PATCH 086/886] random-256 -> 256 random-bits --- extra/channels/remote/remote.factor | 2 +- extra/concurrency/messaging/messaging.factor | 2 +- extra/http/server/auth/providers/providers.factor | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/channels/remote/remote.factor b/extra/channels/remote/remote.factor index 2d8d003b8d..c9cfc83d27 100755 --- a/extra/channels/remote/remote.factor +++ b/extra/channels/remote/remote.factor @@ -14,7 +14,7 @@ IN: channels.remote 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 ; diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor index cfa2aea30d..e566a83fdf 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/extra/concurrency/messaging/messaging.factor @@ -40,7 +40,7 @@ M: thread send ( message thread -- ) TUPLE: synchronous data sender tag ; : ( data -- sync ) - self random-256 synchronous construct-boa ; + self 256 random-bits synchronous construct-boa ; TUPLE: reply data tag ; diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor index d51679016e..cdad4815a6 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/http/server/auth/providers/providers.factor @@ -27,7 +27,7 @@ GENERIC: new-user ( user provider -- user/f ) user email>> length 0 > [ user email>> email = [ user - random-256 >hex >>ticket + 256 random-bits >hex >>ticket dup provider update-user ] [ f ] if ] [ f ] if From 274c7d8cad43f5110d0097df0de9ae1940378ac7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 19 Mar 2008 16:19:54 -0500 Subject: [PATCH 087/886] 256 random-bits --- extra/assocs/lib/lib.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 2500940373..b23ee1f830 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -41,7 +41,7 @@ IN: assocs.lib >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 ) From 077df62492d509a192824ec8210bebd28f65ab91 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 19 Mar 2008 16:20:14 -0500 Subject: [PATCH 088/886] add 2bi* --- extra/combinators/cleave/cleave.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index 049c8bf2a9..9bfbcd6759 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -54,6 +54,8 @@ MACRO: 2cleave ( seq -- ) : bi* ( x y p q -- p(x) q(y) ) >r swap slip r> call ; inline +: 2bi* ( w x y z p q -- p(x) q(y) ) >r -rot 2slip r> call ; inline + : tri* ( x y z p q r -- p(x) q(y) r(z) ) >r rot >r bi* r> r> call ; inline From 1802e7c443a85ff86cc831ad41e4b29d73508600 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 19 Mar 2008 16:22:06 -0500 Subject: [PATCH 089/886] add random bootstrap --- extra/bootstrap/random/random.factor | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 extra/bootstrap/random/random.factor diff --git a/extra/bootstrap/random/random.factor b/extra/bootstrap/random/random.factor new file mode 100644 index 0000000000..7132860e1c --- /dev/null +++ b/extra/bootstrap/random/random.factor @@ -0,0 +1,8 @@ +USING: vocabs.loader sequences system ; + +"random.mersenne-twister" require + +{ + { [ windows? ] [ "random.windows" require ] } + { [ unix? ] [ "random.unix" require ] } +} cond From 3e7940216ec1e456e5ff76321c4fbd6f00d10464 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 19 Mar 2008 19:15:32 -0500 Subject: [PATCH 090/886] swap append to swap append refactoring path+ to append-path swap path+ to prepend-path calendar gmt-offset to duration --- extra/asn1/asn1.factor | 8 +- extra/automata/automata.factor | 2 +- extra/bitfields/bitfields.factor | 2 +- .../bootstrap/image/download/download.factor | 2 +- extra/bootstrap/ui/tools/tools.factor | 2 +- extra/bootstrap/ui/ui.factor | 2 +- extra/builder/builder.factor | 4 +- extra/builder/release/release.factor | 2 +- extra/calendar/backend/backend.factor | 2 +- extra/calendar/calendar-tests.factor | 226 +++++++++--------- extra/calendar/calendar.factor | 29 ++- extra/calendar/format/format-tests.factor | 6 +- extra/calendar/format/format.factor | 36 +-- extra/calendar/unix/unix.factor | 11 +- extra/cocoa/messages/messages.factor | 4 +- extra/combinators/cleave/cleave.factor | 2 +- extra/combinators/lib/lib.factor | 8 +- extra/core-foundation/core-foundation.factor | 2 +- extra/cpu/8080/emulator/emulator.factor | 30 +-- extra/db/sqlite/sqlite.factor | 4 +- extra/db/types/types.factor | 2 +- extra/documents/documents.factor | 2 +- extra/editors/editpadpro/editpadpro.factor | 2 +- extra/editors/editplus/editplus.factor | 2 +- extra/editors/emeditor/emeditor.factor | 2 +- extra/editors/gvim/windows/windows.factor | 2 +- extra/editors/jedit/jedit.factor | 4 +- extra/editors/notepadpp/notepadpp.factor | 2 +- extra/editors/scite/scite.factor | 2 +- extra/editors/ted-notepad/ted-notepad.factor | 2 +- extra/editors/ultraedit/ultraedit.factor | 2 +- extra/editors/wordpad/wordpad.factor | 2 +- extra/faq/faq.factor | 2 +- extra/help/help.factor | 2 +- extra/html/elements/elements.factor | 6 +- extra/http/client/client.factor | 2 +- .../http/server/actions/actions-tests.factor | 4 +- extra/http/server/actions/actions.factor | 4 +- .../http/server/components/components.factor | 2 +- extra/http/server/static/static.factor | 4 +- .../templating/fhtml/fhtml-tests.factor | 2 +- .../http/server/validators/validators.factor | 2 +- extra/io/encodings/utf16/utf16.factor | 4 +- extra/io/files/unique/unique.factor | 4 +- extra/io/paths/paths.factor | 2 +- extra/io/windows/nt/files/files.factor | 8 +- extra/io/windows/nt/nt-tests.factor | 6 +- extra/koszul/koszul.factor | 6 +- extra/locals/locals.factor | 2 +- extra/logging/server/server.factor | 4 +- extra/math/haar/haar.factor | 2 +- extra/new-slots/new-slots.factor | 4 +- extra/optimizer/debugger/debugger.factor | 2 +- extra/project-euler/002/002.factor | 2 +- extra/project-euler/035/035.factor | 2 +- extra/project-euler/project-euler.factor | 4 +- extra/smtp/smtp.factor | 8 +- extra/strings/lib/lib.factor | 2 +- extra/tar/tar.factor | 12 +- extra/tools/deploy/backend/backend.factor | 4 +- extra/tools/deploy/config/config.factor | 2 +- extra/tools/deploy/macosx/macosx.factor | 12 +- extra/tools/deploy/windows/windows.factor | 4 +- extra/tools/vocabs/browser/browser.factor | 4 +- extra/tools/vocabs/vocabs.factor | 18 +- extra/tuple-arrays/tuple-arrays.factor | 2 +- extra/ui/gadgets/lists/lists.factor | 2 +- extra/wrap/wrap.factor | 2 +- extra/xmode/catalog/catalog.factor | 4 +- 69 files changed, 290 insertions(+), 278 deletions(-) diff --git a/extra/asn1/asn1.factor b/extra/asn1/asn1.factor index 99d1e0a19d..8954ffd8cc 100644 --- a/extra/asn1/asn1.factor +++ b/extra/asn1/asn1.factor @@ -135,18 +135,18 @@ SYMBOL: end 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 ; ! ========================================================= @@ -158,7 +158,7 @@ M: bignum >ber ( n -- byte-array ) dup 126 > [ "range error in bignum" throw ] [ - 2 swap 2array "CC" pack-native swap append + 2 swap 2array "CC" pack-native prepend ] if ; ! ========================================================= diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor index cd799d477e..b6d4152d0e 100644 --- a/extra/automata/automata.factor +++ b/extra/automata/automata.factor @@ -46,7 +46,7 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ; : 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 ; diff --git a/extra/bitfields/bitfields.factor b/extra/bitfields/bitfields.factor index 211ab28c92..175f66f4a6 100644 --- a/extra/bitfields/bitfields.factor +++ b/extra/bitfields/bitfields.factor @@ -88,7 +88,7 @@ M: check< summary drop "Number exceeds upper bound" ; >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 ; diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor index df559f49da..a186954ef0 100644 --- a/extra/bootstrap/image/download/download.factor +++ b/extra/bootstrap/image/download/download.factor @@ -18,7 +18,7 @@ bootstrap.image sequences io ; : 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 diff --git a/extra/bootstrap/ui/tools/tools.factor b/extra/bootstrap/ui/tools/tools.factor index c4a555b3e2..a3d02a0016 100755 --- a/extra/bootstrap/ui/tools/tools.factor +++ b/extra/bootstrap/ui/tools/tools.factor @@ -1,7 +1,7 @@ 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 [ diff --git a/extra/bootstrap/ui/ui.factor b/extra/bootstrap/ui/ui.factor index 86538e0000..f8db831dbc 100644 --- a/extra/bootstrap/ui/ui.factor +++ b/extra/bootstrap/ui/ui.factor @@ -8,7 +8,7 @@ vocabs vocabs.loader ; { [ windows? ] [ "windows" ] } { [ unix? ] [ "x11" ] } } cond - ] unless* "ui." swap append require + ] unless* "ui." prepend require "ui.freetype" require ] when diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 7d95ce2409..ea404d6efa 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -58,8 +58,8 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : copy-image ( -- ) - builds "factor" path+ my-boot-image-name path+ ".." copy-file-into - builds "factor" path+ my-boot-image-name path+ "." copy-file-into ; + builds "factor" append-path my-boot-image-name append-path ".." copy-file-into + builds "factor" append-path my-boot-image-name append-path "." copy-file-into ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index f0cf0ee113..0e26abe02f 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -8,7 +8,7 @@ IN: builder.release ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : releases ( -- path ) - builds "releases" path+ + builds "releases" append-path dup exists? not [ dup make-directory ] when ; diff --git a/extra/calendar/backend/backend.factor b/extra/calendar/backend/backend.factor index 15b5e7cb8d..01c36c65ae 100644 --- a/extra/calendar/backend/backend.factor +++ b/extra/calendar/backend/backend.factor @@ -2,4 +2,4 @@ USING: kernel ; IN: calendar.backend SYMBOL: calendar-backend -HOOK: gmt-offset calendar-backend +HOOK: gmt-offset calendar-backend ( -- hours minutes seconds ) diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index 1041c79691..e49d3ad894 100755 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -2,14 +2,14 @@ USING: arrays calendar kernel math sequences tools.test continuations system ; IN: calendar.tests -[ f ] [ 2004 12 32 0 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 2 30 0 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2003 2 29 0 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 -2 9 0 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 12 0 0 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 12 1 24 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 12 1 23 60 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 12 1 23 59 60 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 32 0 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 2 30 0 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2003 2 29 0 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 -2 9 0 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 12 0 0 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 24 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 23 60 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 23 59 60 instant valid-timestamp? ] unit-test [ t ] [ now valid-timestamp? ] unit-test [ f ] [ 1900 leap-year? ] unit-test @@ -18,126 +18,126 @@ IN: calendar.tests [ f ] [ 2001 leap-year? ] unit-test [ f ] [ 2006 leap-year? ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 1 seconds time+ - 2006 10 10 0 0 1 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 100 seconds time+ - 2006 10 10 0 1 40 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 -100 seconds time+ - 2006 10 9 23 58 20 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 86400 seconds time+ - 2006 10 11 0 0 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 1 seconds time+ + 2006 10 10 0 0 1 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 100 seconds time+ + 2006 10 10 0 1 40 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant -100 seconds time+ + 2006 10 9 23 58 20 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 86400 seconds time+ + 2006 10 11 0 0 0 instant = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 10 minutes time+ - 2006 10 10 0 10 0 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 10.5 minutes time+ - 2006 10 10 0 10 30 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 3/4 minutes time+ - 2006 10 10 0 0 45 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 -3/4 minutes time+ - 2006 10 9 23 59 15 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 10 minutes time+ + 2006 10 10 0 10 0 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 10.5 minutes time+ + 2006 10 10 0 10 30 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 3/4 minutes time+ + 2006 10 10 0 0 45 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant -3/4 minutes time+ + 2006 10 9 23 59 15 instant = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 7200 minutes time+ - 2006 10 15 0 0 0 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 -10 minutes time+ - 2006 10 9 23 50 0 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 -100 minutes time+ - 2006 10 9 22 20 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 7200 minutes time+ + 2006 10 15 0 0 0 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant -10 minutes time+ + 2006 10 9 23 50 0 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant -100 minutes time+ + 2006 10 9 22 20 0 instant = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 1 hours time+ - 2006 1 1 1 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 24 hours time+ - 2006 1 2 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -24 hours time+ - 2005 12 31 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 12 hours time+ - 2006 1 1 12 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 72 hours time+ - 2006 1 4 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 1 hours time+ + 2006 1 1 1 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 24 hours time+ + 2006 1 2 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -24 hours time+ + 2005 12 31 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 12 hours time+ + 2006 1 1 12 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 72 hours time+ + 2006 1 4 0 0 0 instant = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 1 days time+ - 2006 1 2 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -1 days time+ - 2005 12 31 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 365 days time+ - 2007 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -365 days time+ - 2005 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 365 days time+ - 2004 12 31 0 0 0 0 = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 366 days time+ - 2005 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 1 days time+ + 2006 1 2 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -1 days time+ + 2005 12 31 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 365 days time+ + 2007 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -365 days time+ + 2005 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2004 1 1 0 0 0 instant 365 days time+ + 2004 12 31 0 0 0 instant = ] unit-test +[ t ] [ 2004 1 1 0 0 0 instant 366 days time+ + 2005 1 1 0 0 0 instant = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 11 months time+ - 2006 12 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 12 months time+ - 2007 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 24 months time+ - 2008 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 13 months time+ - 2007 2 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 1 months time+ - 2006 2 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 0 months time+ - 2006 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -1 months time+ - 2005 12 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -2 months time+ - 2005 11 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -13 months time+ - 2004 12 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -24 months time+ - 2004 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2004 2 29 0 0 0 0 12 months time+ - 2005 3 1 0 0 0 0 = ] unit-test -[ t ] [ 2004 2 29 0 0 0 0 -12 months time+ - 2003 3 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 11 months time+ + 2006 12 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 12 months time+ + 2007 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 24 months time+ + 2008 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 13 months time+ + 2007 2 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 1 months time+ + 2006 2 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 0 months time+ + 2006 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -1 months time+ + 2005 12 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -2 months time+ + 2005 11 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -13 months time+ + 2004 12 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -24 months time+ + 2004 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2004 2 29 0 0 0 instant 12 months time+ + 2005 3 1 0 0 0 instant = ] unit-test +[ t ] [ 2004 2 29 0 0 0 instant -12 months time+ + 2003 3 1 0 0 0 instant = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 0 years time+ - 2006 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 1 years time+ - 2007 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -1 years time+ - 2005 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -100 years time+ - 1906 1 1 0 0 0 0 = ] unit-test -! [ t ] [ 2004 2 29 0 0 0 0 -1 years time+ -! 2003 2 28 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 0 years time+ + 2006 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 1 years time+ + 2007 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -1 years time+ + 2005 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -100 years time+ + 1906 1 1 0 0 0 instant = ] unit-test +! [ t ] [ 2004 2 29 0 0 0 instant -1 years time+ +! 2003 2 28 0 0 0 instant = ] unit-test -[ 5 ] [ 2006 7 14 0 0 0 0 day-of-week ] unit-test +[ 5 ] [ 2006 7 14 0 0 0 instant day-of-week ] unit-test -[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 ] 3keep 0 0 0 0 = ] unit-test +[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 instant ] 3keep 0 0 0 instant = ] unit-test -[ 1 ] [ 2006 1 1 0 0 0 0 day-of-year ] unit-test -[ 60 ] [ 2004 2 29 0 0 0 0 day-of-year ] unit-test -[ 61 ] [ 2004 3 1 0 0 0 0 day-of-year ] unit-test -[ 366 ] [ 2004 12 31 0 0 0 0 day-of-year ] unit-test -[ 365 ] [ 2003 12 31 0 0 0 0 day-of-year ] unit-test -[ 60 ] [ 2003 3 1 0 0 0 0 day-of-year ] unit-test +[ 1 ] [ 2006 1 1 0 0 0 instant day-of-year ] unit-test +[ 60 ] [ 2004 2 29 0 0 0 instant day-of-year ] unit-test +[ 61 ] [ 2004 3 1 0 0 0 instant day-of-year ] unit-test +[ 366 ] [ 2004 12 31 0 0 0 instant day-of-year ] unit-test +[ 365 ] [ 2003 12 31 0 0 0 instant day-of-year ] unit-test +[ 60 ] [ 2003 3 1 0 0 0 instant day-of-year ] unit-test -[ t ] [ 2004 12 31 0 0 0 0 dup = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 10 seconds 5 years time+ time+ - 2009 1 1 0 0 10 0 = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 -10 seconds -5 years time+ time+ - 1998 12 31 23 59 50 0 = ] unit-test +[ t ] [ 2004 12 31 0 0 0 instant dup = ] unit-test +[ t ] [ 2004 1 1 0 0 0 instant 10 seconds 5 years time+ time+ + 2009 1 1 0 0 10 instant = ] unit-test +[ t ] [ 2004 1 1 0 0 0 instant -10 seconds -5 years time+ time+ + 1998 12 31 23 59 50 instant = ] unit-test -[ t ] [ 2004 1 1 23 0 0 12 0 convert-timezone - 2004 1 1 11 0 0 0 = ] unit-test -[ t ] [ 2004 1 1 5 0 0 -11 0 convert-timezone - 2004 1 1 16 0 0 0 = ] unit-test -[ t ] [ 2004 1 1 23 0 0 9+1/2 0 convert-timezone - 2004 1 1 13 30 0 0 = ] unit-test +[ t ] [ 2004 1 1 23 0 0 12 hours >gmt + 2004 1 1 11 0 0 instant = ] unit-test +[ t ] [ 2004 1 1 5 0 0 -11 hours >gmt + 2004 1 1 16 0 0 instant = ] unit-test +[ t ] [ 2004 1 1 23 0 0 9+1/2 hours >gmt + 2004 1 1 13 30 0 instant = ] unit-test -[ 0 ] [ 2004 1 1 13 30 0 0 - 2004 1 1 12 30 0 -1 <=> ] unit-test +[ 0 ] [ 2004 1 1 13 30 0 instant + 2004 1 1 12 30 0 -1 hours <=> ] unit-test -[ 1 ] [ 2004 1 1 13 30 0 0 - 2004 1 1 12 30 0 0 <=> ] unit-test +[ 1 ] [ 2004 1 1 13 30 0 instant + 2004 1 1 12 30 0 instant <=> ] unit-test -[ -1 ] [ 2004 1 1 12 30 0 0 - 2004 1 1 13 30 0 0 <=> ] unit-test +[ -1 ] [ 2004 1 1 12 30 0 instant + 2004 1 1 13 30 0 instant <=> ] unit-test -[ 1 ] [ 2005 1 1 12 30 0 0 - 2004 1 1 13 30 0 0 <=> ] unit-test +[ 1 ] [ 2005 1 1 12 30 0 instant + 2004 1 1 13 30 0 instant <=> ] unit-test [ t ] [ now timestamp>millis millis - 1000 < ] unit-test [ t ] [ 0 millis>timestamp unix-1970 = ] unit-test diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 2b80a8dce6..457b0bea11 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -3,20 +3,23 @@ USING: arrays kernel math math.functions namespaces sequences strings tuples system vocabs.loader calendar.backend threads -new-slots accessors combinators ; +new-slots accessors combinators locals ; IN: calendar TUPLE: timestamp year month day hour minute second gmt-offset ; C: timestamp -: ( year month day -- timestamp ) - 0 0 0 gmt-offset ; - TUPLE: duration year month day hour minute second ; C: duration +: gmt-offset-duration ( -- duration ) + 0 0 0 gmt-offset ; + +: ( year month day -- timestamp ) + 0 0 0 gmt-offset-duration ; + : month-names { "Not a month" "January" "February" "March" "April" "May" "June" @@ -226,16 +229,18 @@ 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 ; @@ -245,8 +250,6 @@ M: timestamp <=> ( ts1 ts2 -- n ) [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ; -GENERIC: time- ( time1 time2 -- time ) - M: timestamp time- #! Exact calendar-time difference (time-) seconds ; @@ -263,14 +266,14 @@ M: timestamp time- M: duration time- before time+ ; -: 0 0 0 0 0 0 0 ; +: 0 0 0 0 0 0 instant ; : valid-timestamp? ( timestamp -- ? ) - clone 0 >>gmt-offset + clone instant >>gmt-offset dup time- time+ = ; : unix-1970 ( -- timestamp ) - 1970 1 1 0 0 0 0 ; foldable + 1970 1 1 0 0 0 instant ; foldable : millis>timestamp ( n -- timestamp ) >r unix-1970 r> milliseconds time+ ; diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor index eb32ce5b43..88bd0733c0 100755 --- a/extra/calendar/format/format-tests.factor +++ b/extra/calendar/format/format-tests.factor @@ -1,5 +1,6 @@ +USING: calendar.format calendar kernel tools.test +io.streams.string ; IN: calendar.format.tests -USING: calendar.format tools.test io.streams.string ; [ 0 ] [ "Z" [ read-rfc3339-gmt-offset ] with-string-reader @@ -20,3 +21,6 @@ USING: calendar.format tools.test io.streams.string ; [ 1+1/2 ] [ "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader ] unit-test + +[ ] [ now timestamp>rfc3339 drop ] unit-test +[ ] [ now timestamp>rfc822 drop ] unit-test diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index 89e09e0d0c..0ac0ebb2c3 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -1,6 +1,7 @@ -IN: calendar.format USING: math math.parser kernel sequences io calendar -accessors arrays io.streams.string combinators accessors ; +accessors arrays io.streams.string combinators accessors +combinators.cleave ; +IN: calendar.format GENERIC: day. ( obj -- ) @@ -54,17 +55,17 @@ M: timestamp year. ( timestamp -- ) : timestamp>string ( timestamp -- str ) [ (timestamp>string) ] with-string-writer ; -: (write-gmt-offset) ( ratio -- ) - 1 /mod swap write-00 60 * write-00 ; +: (write-gmt-offset) ( duration -- ) + [ hour>> write-00 ] [ minute>> write-00 ] bi ; : write-gmt-offset ( gmt-offset -- ) - { - { [ dup zero? ] [ drop "GMT" write ] } - { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] } - { [ dup 0 > ] [ "+" write (write-gmt-offset) ] } + dup instant <=> { + { [ dup 0 = ] [ 2drop "GMT" write ] } + { [ dup 0 < ] [ drop "-" write before (write-gmt-offset) ] } + { [ dup 0 > ] [ drop "+" write (write-gmt-offset) ] } } cond ; -: timestamp>rfc822-string ( timestamp -- str ) +: timestamp>rfc822 ( timestamp -- str ) #! RFC822 timestamp format #! Example: Tue, 15 Nov 1994 08:12:31 +0200 [ @@ -76,14 +77,19 @@ M: timestamp year. ( timestamp -- ) : timestamp>http-string ( timestamp -- str ) #! http timestamp format #! Example: Tue, 15 Nov 1994 08:12:31 GMT - >gmt timestamp>rfc822-string ; + >gmt timestamp>rfc822 ; -: write-rfc3339-gmt-offset ( n -- ) - dup zero? [ drop "Z" write ] [ - dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if - 60 * 60 /mod swap write-00 CHAR: : write1 write-00 - ] if ; +: (write-rfc3339-gmt-offset) ( duration -- ) + [ hour>> write-00 CHAR: : write1 ] + [ minute>> write-00 ] bi ; +: write-rfc3339-gmt-offset ( duration -- ) + dup instant <=> { + { [ dup 0 = ] [ 2drop "Z" write ] } + { [ dup 0 < ] [ drop CHAR: - write1 before (write-rfc3339-gmt-offset) ] } + { [ dup 0 > ] [ drop CHAR: + write1 (write-rfc3339-gmt-offset) ] } + } cond ; + : (timestamp>rfc3339) ( timestamp -- ) dup year>> number>string write CHAR: - write1 dup month>> write-00 CHAR: - write1 diff --git a/extra/calendar/unix/unix.factor b/extra/calendar/unix/unix.factor index 30e22c487b..2877fa07b5 100644 --- a/extra/calendar/unix/unix.factor +++ b/extra/calendar/unix/unix.factor @@ -1,6 +1,5 @@ - USING: alien alien.c-types arrays calendar.backend - kernel structs math unix.time namespaces ; +kernel structs math unix.time namespaces ; IN: calendar.unix @@ -8,11 +7,11 @@ TUPLE: unix-calendar ; T{ unix-calendar } calendar-backend set-global -: get-time +: get-time ( -- alien ) f time localtime ; -: timezone-name +: timezone-name ( -- string ) get-time tm-zone ; -M: unix-calendar gmt-offset - get-time tm-gmtoff 3600 / ; +M: unix-calendar gmt-offset ( -- hours minutes seconds ) + get-time tm-gmtoff 3600 /mod 60 /mod ; diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor index e2072f441c..480e19b005 100755 --- a/extra/cocoa/messages/messages.factor +++ b/extra/cocoa/messages/messages.factor @@ -59,7 +59,7 @@ objc-methods global [ H{ } assoc-like ] change-at : 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 @@ -90,7 +90,7 @@ MACRO: (send) ( selector super? -- quot ) ! 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) ; diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index 9bfbcd6759..1bc7480198 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -70,7 +70,7 @@ MACRO: spread ( seq -- ) dup [ drop [ >r ] ] map concat swap - [ [ r> ] swap append ] map concat + [ [ r> ] prepend ] map concat append ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 07a9a6d43d..459938c885 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -75,11 +75,11 @@ MACRO: && ( quots -- ? ) [ [ 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 ; @@ -130,12 +130,12 @@ MACRO: map-call-with ( quots -- ) [ (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 ; diff --git a/extra/core-foundation/core-foundation.factor b/extra/core-foundation/core-foundation.factor index 297e4aec87..73b8fce229 100644 --- a/extra/core-foundation/core-foundation.factor +++ b/extra/core-foundation/core-foundation.factor @@ -83,7 +83,7 @@ FUNCTION: void CFRelease ( void* cf ) ; dup [ CFBundleLoadExecutable drop ] [ - "Cannot load bundled named " swap append throw + "Cannot load bundled named " prepend throw ] ?if ; FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ; diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index 24eceee744..d4574119b2 100755 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -446,7 +446,7 @@ M: cpu reset ( cpu -- ) 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 @@ -455,7 +455,7 @@ SYMBOL: rom-root #! 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 @@ -1027,14 +1027,14 @@ SYMBOL: $4 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 @@ -1047,14 +1047,14 @@ SYMBOL: $4 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 @@ -1082,21 +1082,21 @@ SYMBOL: $4 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 @@ -1124,28 +1124,28 @@ SYMBOL: $4 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 @@ -1194,14 +1194,14 @@ SYMBOL: $4 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 diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index bca904279b..d7d954c0dc 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -71,7 +71,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- ) [ statement-in-params [ - [ sql-spec-column-name ":" swap append ] + [ sql-spec-column-name ":" prepend ] [ sql-spec-slot-name rot get-slot-named ] [ sql-spec-type ] tri 3array ] with map @@ -173,7 +173,7 @@ M: sqlite-db ( specs table -- sql ) ! : select-sequence ( seq name -- ) ; M: sqlite-db bind% ( spec -- ) - dup 1, sql-spec-column-name ":" swap append 0% ; + dup 1, sql-spec-column-name ":" prepend 0% ; M: sqlite-db ( tuple class -- statement ) [ diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index a0414f334d..94a8d6f392 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -127,7 +127,7 @@ TUPLE: no-sql-modifier ; : modifiers ( spec -- str ) sql-spec-modifiers [ lookup-modifier ] map " " join - dup empty? [ " " swap append ] unless ; + dup empty? [ " " prepend ] unless ; HOOK: bind% db ( spec -- ) diff --git a/extra/documents/documents.factor b/extra/documents/documents.factor index 993e69ec14..60ae592d4c 100755 --- a/extra/documents/documents.factor +++ b/extra/documents/documents.factor @@ -74,7 +74,7 @@ TUPLE: document locs ; 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 ; diff --git a/extra/editors/editpadpro/editpadpro.factor b/extra/editors/editpadpro/editpadpro.factor index eb31b2aa47..9da57e16bf 100755 --- a/extra/editors/editpadpro/editpadpro.factor +++ b/extra/editors/editpadpro/editpadpro.factor @@ -5,7 +5,7 @@ IN: editors.editpadpro : editpadpro-path \ editpadpro-path get-global [ - program-files "JGsoft" path+ + program-files "JGsoft" append-path t [ >lower "editpadpro.exe" tail? ] find-file ] unless* ; diff --git a/extra/editors/editplus/editplus.factor b/extra/editors/editplus/editplus.factor index ee24c99463..363d202f6c 100755 --- a/extra/editors/editplus/editplus.factor +++ b/extra/editors/editplus/editplus.factor @@ -4,7 +4,7 @@ IN: editors.editplus : 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 -- ) diff --git a/extra/editors/emeditor/emeditor.factor b/extra/editors/emeditor/emeditor.factor index bed333694c..8aecb49ae5 100755 --- a/extra/editors/emeditor/emeditor.factor +++ b/extra/editors/emeditor/emeditor.factor @@ -4,7 +4,7 @@ IN: editors.emeditor : emeditor-path ( -- path ) \ emeditor-path get-global [ - program-files "\\EmEditor\\EmEditor.exe" path+ + program-files "\\EmEditor\\EmEditor.exe" append-path ] unless* ; : emeditor ( file line -- ) diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor index 030c968e81..489000498e 100755 --- a/extra/editors/gvim/windows/windows.factor +++ b/extra/editors/gvim/windows/windows.factor @@ -4,6 +4,6 @@ IN: editors.gvim.windows M: windows-io gvim-path \ gvim-path get-global [ - program-files "vim" path+ + program-files "vim" append-path t [ "gvim.exe" tail? ] find-file ] unless* ; diff --git a/extra/editors/jedit/jedit.factor b/extra/editors/jedit/jedit.factor index 3ce2c40192..7b6066df7c 100644 --- a/extra/editors/jedit/jedit.factor +++ b/extra/editors/jedit/jedit.factor @@ -8,7 +8,7 @@ io.encodings.utf8 ; 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 @@ -32,7 +32,7 @@ IN: editors.jedit ] 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 -- ) diff --git a/extra/editors/notepadpp/notepadpp.factor b/extra/editors/notepadpp/notepadpp.factor index 72ac6c72d7..959e633cc3 100755 --- a/extra/editors/notepadpp/notepadpp.factor +++ b/extra/editors/notepadpp/notepadpp.factor @@ -4,7 +4,7 @@ IN: editors.notepadpp : notepadpp-path \ notepadpp-path get-global [ - program-files "notepad++\\notepad++.exe" path+ + program-files "notepad++\\notepad++.exe" append-path ] unless* ; : notepadpp ( file line -- ) diff --git a/extra/editors/scite/scite.factor b/extra/editors/scite/scite.factor index ac9a032abc..a0bacaabba 100755 --- a/extra/editors/scite/scite.factor +++ b/extra/editors/scite/scite.factor @@ -14,7 +14,7 @@ IN: editors.scite : 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 ) diff --git a/extra/editors/ted-notepad/ted-notepad.factor b/extra/editors/ted-notepad/ted-notepad.factor index 5d58e182a3..9b341dd2a8 100755 --- a/extra/editors/ted-notepad/ted-notepad.factor +++ b/extra/editors/ted-notepad/ted-notepad.factor @@ -4,7 +4,7 @@ IN: editors.ted-notepad : 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 -- ) diff --git a/extra/editors/ultraedit/ultraedit.factor b/extra/editors/ultraedit/ultraedit.factor index f9d27174b3..1fef9f3350 100755 --- a/extra/editors/ultraedit/ultraedit.factor +++ b/extra/editors/ultraedit/ultraedit.factor @@ -5,7 +5,7 @@ IN: editors.ultraedit : 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 -- ) diff --git a/extra/editors/wordpad/wordpad.factor b/extra/editors/wordpad/wordpad.factor index 5ad08b613b..d1f979e0f3 100755 --- a/extra/editors/wordpad/wordpad.factor +++ b/extra/editors/wordpad/wordpad.factor @@ -5,7 +5,7 @@ IN: editors.wordpad : 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 -- ) diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor index 7ad3900163..d7624466f7 100644 --- a/extra/faq/faq.factor +++ b/extra/faq/faq.factor @@ -79,7 +79,7 @@ C: faq "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 -- ) diff --git a/extra/help/help.factor b/extra/help/help.factor index 34e90b2ccf..4cb8cfe854 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -98,7 +98,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; : about ( vocab -- ) dup require dup vocab [ ] [ - "No such vocabulary: " swap append throw + "No such vocabulary: " prepend throw ] ?if dup vocab-help [ help diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 286037d4dc..754afb1ea7 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -38,7 +38,7 @@ IN: html.elements ! "Click me" write ! ! (url -- ) -! "click" write +! "click" write ! ! (url -- ) ! "click" write @@ -72,7 +72,7 @@ SYMBOL: html dup swap [ write-html ] curry empty-effect html-word ; -: - [ +path+ get "xxx" get "X" concat append ] >>submit - { { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params + [ +append-path get "xxx" get "X" concat append ] >>submit + { { +append-path [ ] } { "xxx" [ v-number ] } } >>post-params "action-2" set STRING: action-request-test-2 diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index 52567ed352..287f6dd907 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -5,7 +5,7 @@ http.server http.server.validators http hashtables namespaces combinators.cleave fry continuations locals ; IN: http.server.actions -SYMBOL: +path+ +SYMBOL: +append-path SYMBOL: params @@ -40,7 +40,7 @@ TUPLE: action init display submit get-params post-params ; M: action call-responder ( path action -- response ) '[ , , - [ +path+ associate request-params union params set ] + [ +append-path associate request-params union params set ] [ action set ] bi* request get method>> { { "GET" [ handle-get ] } diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 02c992651a..8581335f3d 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -13,7 +13,7 @@ TUPLE: component id required default ; : component ( name -- component ) dup components get at - [ ] [ "No such component: " swap append throw ] ?if ; + [ ] [ "No such component: " prepend throw ] ?if ; GENERIC: validate* ( value component -- result ) GENERIC: render-view* ( value component -- ) diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index b408b1b6b0..b001242776 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -39,7 +39,7 @@ TUPLE: file-responder root hook special ; [ 2drop <304> ] [ file-responder get hook>> call ] if ; : serving-path ( filename -- filename ) - "" or file-responder get root>> swap path+ ; + "" or file-responder get root>> prepend-path ; : serve-file ( filename -- response ) dup mime-type @@ -68,7 +68,7 @@ TUPLE: file-responder root hook special ; swap '[ , directory. ] >>body ; : find-index ( filename -- path ) - { "index.html" "index.fhtml" } [ path+ ] with map + { "index.html" "index.fhtml" } [ append-path ] with map [ exists? ] find nip ; : serve-directory ( filename -- response ) diff --git a/extra/http/server/templating/fhtml/fhtml-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor index 9774e4c1f2..2e253d9132 100755 --- a/extra/http/server/templating/fhtml/fhtml-tests.factor +++ b/extra/http/server/templating/fhtml/fhtml-tests.factor @@ -5,7 +5,7 @@ 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 ] keep diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor index 539a58d19f..f2d1f568e6 100755 --- a/extra/http/server/validators/validators.factor +++ b/extra/http/server/validators/validators.factor @@ -59,7 +59,7 @@ C: validation-error : 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 diff --git a/extra/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor index 290761ec91..05dc7235f6 100755 --- a/extra/io/encodings/utf16/utf16.factor +++ b/extra/io/encodings/utf16/utf16.factor @@ -18,13 +18,13 @@ TUPLE: utf16 ; over [ 8 shift bitor ] [ 2drop replacement-char ] if ; : double-be ( stream byte -- stream char ) - over stream-read1 swap append-nums ; + over stream-read1 prepend-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 + + over stream-read1 prepend-nums HEX: 10000 + ] [ 2drop dup stream-read1 drop replacement-char ] if ] when* ; diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor index 1e77cd6814..9a271e402c 100644 --- a/extra/io/files/unique/unique.factor +++ b/extra/io/files/unique/unique.factor @@ -24,7 +24,7 @@ PRIVATE> : make-unique-file ( prefix suffix -- path stream ) 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 ; @@ -36,7 +36,7 @@ PRIVATE> : 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 ; diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index 4acfb9acad..163194195d 100755 --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -5,7 +5,7 @@ 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> [ diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index dda94da892..7cf056674f 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -32,9 +32,9 @@ M: windows-nt-io root-directory? ( path -- ? ) } && [ 2 head ] [ "Not an absolute path" throw ] if ; : prepend-prefix ( string -- string' ) - unicode-prefix swap append ; + unicode-prefix prepend ; -: windows-path+ ( cwd path -- newpath ) +: windows-append-path ( cwd path -- newpath ) { ! empty { [ dup empty? ] [ drop ] } @@ -43,7 +43,7 @@ M: windows-nt-io root-directory? ( path -- ? ) ! \\\\?\\c:\\foo { [ dup unicode-prefix head? ] [ nip ] } ! ..\\foo - { [ dup "..\\" head? ] [ >r parent-directory r> 3 tail windows-path+ ] } + { [ dup "..\\" head? ] [ >r parent-directory r> 3 tail windows-append-path ] } ! .\\foo { [ dup ".\\" head? ] [ 1 tail append prepend-prefix ] } ! \\foo @@ -62,7 +62,7 @@ M: windows-nt-io normalize-pathname ( string -- string ) dup string? [ "Pathname must be a string" throw ] unless dup empty? [ "Empty pathname" throw ] when { { CHAR: / CHAR: \\ } } substitute - cwd swap windows-path+ + cwd swap windows-append-path [ "/\\." member? ] right-trim dup peek CHAR: : = [ "\\" append ] when ; diff --git a/extra/io/windows/nt/nt-tests.factor b/extra/io/windows/nt/nt-tests.factor index c4ac99fe4a..6353bfe86e 100755 --- a/extra/io/windows/nt/nt-tests.factor +++ b/extra/io/windows/nt/nt-tests.factor @@ -22,15 +22,15 @@ IN: io.windows.nt.tests [ "\\\\?\\C:\\builds\\factor\\log.txt" ] [ "C:\\builds\\factor\\12345\\" - "..\\log.txt" windows-path+ + "..\\log.txt" windows-append-path ] unit-test [ "\\\\?\\C:\\builds\\" ] [ "C:\\builds\\factor\\12345\\" - "..\\.." windows-path+ + "..\\.." windows-append-path ] unit-test [ "\\\\?\\C:\\builds\\" ] [ "C:\\builds\\factor\\12345\\" - "..\\.." windows-path+ + "..\\.." windows-append-path ] unit-test diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index 69de838eec..71cbb1d951 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -33,7 +33,7 @@ SYMBOL: terms { { [ dup 1 = ] [ drop " + " ] } { [ dup -1 = ] [ drop " - " ] } - { [ t ] [ number>string " + " swap append ] } + { [ t ] [ number>string " + " prepend ] } } cond ; : (alt.) ( basis n -- str ) @@ -155,7 +155,7 @@ DEFER: (d) : (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 ) @@ -202,7 +202,7 @@ DEFER: (d) : bigraded-betti ( u-generators z-generators -- seq ) [ basis graded ] 2apply tensor bigraded-ker/im-d [ [ [ first ] map ] map ] keep - [ [ second ] map 2 head* { 0 0 } swap append ] map + [ [ second ] map 2 head* { 0 0 } prepend ] map 1 tail dup first length 0 add [ v- ] 2map ; diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index a8f5e139e7..9f96a3444d 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -176,7 +176,7 @@ M: block lambda-rewrite* #! Turn free variables into bound variables, curry them #! onto the body dup free-vars [ ] map dup % [ - over block-vars swap append + over block-vars prepend swap block-body [ [ lambda-rewrite* ] each ] [ ] make swap point-free , ] keep length \ curry % ; diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index 372216c45e..bed6a2fec3 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -11,10 +11,10 @@ IN: logging.server \ log-root get "logs" resource-path or ; : log-path ( service -- path ) - log-root swap path+ ; + log-root prepend-path ; : log# ( path n -- path' ) - number>string ".log" append path+ ; + number>string ".log" append append-path ; SYMBOL: log-files diff --git a/extra/math/haar/haar.factor b/extra/math/haar/haar.factor index 13eaa479a5..91d9fd8ece 100644 --- a/extra/math/haar/haar.factor +++ b/extra/math/haar/haar.factor @@ -12,4 +12,4 @@ IN: math.haar 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 ; diff --git a/extra/new-slots/new-slots.factor b/extra/new-slots/new-slots.factor index 3273036b8b..9773da7b41 100755 --- a/extra/new-slots/new-slots.factor +++ b/extra/new-slots/new-slots.factor @@ -27,7 +27,7 @@ IN: new-slots : setter-effect T{ effect f { "object" "value" } { "value" } } ; inline : setter-word ( name -- word ) - ">>" swap append setter-effect create-accessor ; + ">>" prepend setter-effect create-accessor ; : define-setter ( name -- ) dup setter-word dup deferred? [ @@ -37,7 +37,7 @@ IN: new-slots : changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline : changer-word ( name -- word ) - "change-" swap append changer-effect create-accessor ; + "change-" prepend changer-effect create-accessor ; : define-changer ( name -- ) dup changer-word dup deferred? [ diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index 3cbddf8296..1f5453798d 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -65,7 +65,7 @@ MATCH-VARS: ?a ?b ?c ; 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 ; diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index 0b8f773887..b660ed0958 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -41,7 +41,7 @@ PRIVATE> : 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 ; diff --git a/extra/project-euler/035/035.factor b/extra/project-euler/035/035.factor index d8d38d1647..9873abf05c 100755 --- a/extra/project-euler/035/035.factor +++ b/extra/project-euler/035/035.factor @@ -34,7 +34,7 @@ IN: project-euler.035 ] if ; : rotate ( seq n -- seq ) - cut* swap append ; + cut* prepend ; : (circular?) ( seq n -- ? ) dup 0 > [ diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 25ddd9a60b..04339ad5b7 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -30,7 +30,7 @@ IN: project-euler number>string 3 CHAR: 0 pad-left ; : solution-path ( n -- str/f ) - number>euler "project-euler." swap append + number>euler "project-euler." prepend vocab where dup [ first ?resource-path ] when ; PRIVATE> @@ -40,7 +40,7 @@ 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 ] [ diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index a941b14a47..f7cdf9e64d 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -31,7 +31,7 @@ LOG: log-smtp-connection NOTICE ( addrspec -- ) : 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 ; + [ "Bad e-mail address: " prepend throw ] unless ; : mail-from ( fromaddr -- ) "MAIL FROM:<" write validate-address write ">" write crlf ; @@ -89,7 +89,7 @@ LOG: smtp-response DEBUG : validate-header ( string -- string' ) dup "\r\n" seq-intersect empty? - [ "Invalid header string: " swap append throw ] unless ; + [ "Invalid header string: " prepend throw ] unless ; : write-header ( key value -- ) swap @@ -143,7 +143,7 @@ M: email clone 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 ) @@ -164,7 +164,7 @@ M: email clone ! : (cram-md5-auth) ( -- response ) ! swap challenge get ! string>md5-hmac hex-string -! " " swap append append +! " " prepend append ! >base64 ; ! ! : cram-md5-auth ( key login -- ) diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor index 7f13cd58a9..c6299e6b08 100644 --- a/extra/strings/lib/lib.factor +++ b/extra/strings/lib/lib.factor @@ -7,7 +7,7 @@ IN: strings.lib : >Upper ( str -- str ) dup empty? [ - unclip ch>upper 1string swap append + unclip ch>upper 1string prepend ] unless ; : >Upper-dashes ( str -- str ) diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 06e9644370..d1c4b148a5 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -89,12 +89,12 @@ TUPLE: unimplemented-typeflag header ; 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 + tar-header-name tar-append-path binary [ read-data-blocks ] keep dispose ; ! Hard link @@ -115,7 +115,7 @@ TUPLE: unimplemented-typeflag header ; ! Directory : typeflag-5 ( header -- ) - tar-header-name tar-path+ make-directories ; + tar-header-name tar-append-path make-directories ; ! FIFO : typeflag-6 ( header -- ) @@ -166,7 +166,7 @@ TUPLE: unimplemented-typeflag header ; [ 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 -- ) @@ -226,7 +226,7 @@ TUPLE: unimplemented-typeflag header ; ! 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 ! out-stream set diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 60dc11257f..2476077ba9 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -79,9 +79,9 @@ IN: tools.deploy.backend "-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 diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor index 78f1d487de..c527cb945c 100755 --- a/extra/tools/deploy/config/config.factor +++ b/extra/tools/deploy/config/config.factor @@ -66,7 +66,7 @@ SYMBOL: deploy-image } 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 diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 6db19cf868..9fe35647fe 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -10,15 +10,15 @@ IN: tools.deploy.macosx 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 ; + "Contents/MacOS/" append-path prepend-path vm over copy-file ; : copy-fonts ( name -- ) "fonts/" resource-path - swap "Contents/Resources/" path+ copy-tree-into ; + swap "Contents/Resources/" append-path copy-tree-into ; : app-plist ( executable bundle-name -- string ) [ @@ -30,12 +30,12 @@ IN: tools.deploy.macosx file-name "CFBundleName" set dup "CFBundleExecutable" set - "org.factor." swap append "CFBundleIdentifier" set + "org.factor." prepend "CFBundleIdentifier" set ] H{ } make-assoc plist>string ; : create-app-plist ( vocab bundle-name -- ) [ app-plist ] keep - "Contents/Info.plist" path+ + "Contents/Info.plist" append-path utf8 set-file-contents ; : create-app-dir ( vocab bundle-name -- vm ) diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor index 6a2ce448af..1c9a8195c5 100755 --- a/extra/tools/deploy/windows/windows.factor +++ b/extra/tools/deploy/windows/windows.factor @@ -6,7 +6,7 @@ prettyprint windows.shell32 windows.user32 ; IN: tools.deploy.windows : copy-vm ( executable bundle-name -- vm ) - swap path+ ".exe" append + prepend-path ".exe" append vm over copy-file ; : copy-fonts ( bundle-name -- ) @@ -23,7 +23,7 @@ IN: tools.deploy.windows copy-vm ; : image-name ( vocab bundle-name -- str ) - swap path+ ".image" append ; + prepend-path ".image" append ; TUPLE: windows-deploy-implementation ; diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor index 06eba5f65c..69ad9272a7 100755 --- a/extra/tools/vocabs/browser/browser.factor +++ b/extra/tools/vocabs/browser/browser.factor @@ -31,7 +31,7 @@ IN: tools.vocabs.browser ] with-row ; : root-heading. ( root -- ) - [ "Children from " swap append ] [ "Children" ] if* + [ "Children from " prepend ] [ "Children" ] if* $heading ; : vocabs. ( assoc -- ) @@ -195,7 +195,7 @@ M: vocab-tag summary article-title ; 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 ; diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 2f2e834808..d7e1070666 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -7,15 +7,15 @@ io debugger continuations compiler.errors init io.crc32 ; IN: tools.vocabs : vocab-tests-file ( vocab -- path ) - dup "-tests.factor" vocab-dir+ vocab-path+ dup + dup "-tests.factor" vocab-dir+ vocab-append-path dup [ dup resource-exists? [ drop f ] unless ] [ drop f ] if ; : vocab-tests-dir ( vocab -- paths ) - dup vocab-dir "tests" path+ vocab-path+ dup [ + dup vocab-dir "tests" append-path vocab-append-path dup [ dup resource-exists? [ dup ?resource-path directory keys [ ".factor" tail? ] subset - [ path+ ] with map + [ append-path ] with map ] [ drop f ] if ] [ drop f ] if ; @@ -103,10 +103,10 @@ MEMO: (vocab-file-contents) ( path -- lines ) [ utf8 file-lines ] [ drop f ] if ; : vocab-file-contents ( vocab name -- seq ) - vocab-path+ dup [ (vocab-file-contents) ] when ; + vocab-append-path dup [ (vocab-file-contents) ] when ; : set-vocab-file-contents ( seq vocab name -- ) - dupd vocab-path+ [ + dupd vocab-append-path [ ?resource-path utf8 set-file-lines ] [ "The " swap vocab-name @@ -115,7 +115,7 @@ MEMO: (vocab-file-contents) ( path -- lines ) ] ?if ; : vocab-summary-path ( vocab -- string ) - vocab-dir "summary.txt" path+ ; + vocab-dir "summary.txt" append-path ; : vocab-summary ( vocab -- summary ) dup dup vocab-summary-path vocab-file-contents @@ -141,7 +141,7 @@ M: vocab-link summary vocab-summary ; set-vocab-file-contents ; : vocab-tags-path ( vocab -- string ) - vocab-dir "tags.txt" path+ ; + vocab-dir "tags.txt" append-path ; : vocab-tags ( vocab -- tags ) dup vocab-tags-path vocab-file-contents ; @@ -153,7 +153,7 @@ M: vocab-link summary vocab-summary ; [ vocab-tags append prune ] keep set-vocab-tags ; : vocab-authors-path ( vocab -- string ) - vocab-dir "authors.txt" path+ ; + vocab-dir "authors.txt" append-path ; : vocab-authors ( vocab -- authors ) dup vocab-authors-path vocab-file-contents ; @@ -165,7 +165,7 @@ M: vocab-link summary vocab-summary ; directory [ second ] subset keys natural-sort ; : (all-child-vocabs) ( root name -- vocabs ) - [ vocab-dir path+ ?resource-path subdirs ] keep + [ vocab-dir append-path ?resource-path subdirs ] keep dup empty? [ drop ] [ diff --git a/extra/tuple-arrays/tuple-arrays.factor b/extra/tuple-arrays/tuple-arrays.factor index 7a1df7ac1d..061deec6ec 100644 --- a/extra/tuple-arrays/tuple-arrays.factor +++ b/extra/tuple-arrays/tuple-arrays.factor @@ -15,7 +15,7 @@ TUPLE: tuple-array example ; [ set-tuple-array-example ] keep ; : reconstruct ( seq example -- tuple ) - swap append >tuple ; + prepend >tuple ; M: tuple-array nth [ delegate nth ] keep diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor index 5fbe9ba0eb..3bac7969c5 100755 --- a/extra/ui/gadgets/lists/lists.factor +++ b/extra/ui/gadgets/lists/lists.factor @@ -27,7 +27,7 @@ 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 ; : ( hook elt presenter -- gadget ) keep diff --git a/extra/wrap/wrap.factor b/extra/wrap/wrap.factor index 41dea1bd13..a2ca25ce6e 100644 --- a/extra/wrap/wrap.factor +++ b/extra/wrap/wrap.factor @@ -29,4 +29,4 @@ SYMBOL: width 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 ; diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor index 6bff786fff..c7eaafe887 100755 --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -37,13 +37,13 @@ TAGS> MEMO: (load-mode) ( name -- rule-sets ) modes at mode-file - "extra/xmode/modes/" swap append + "extra/xmode/modes/" prepend resource-path utf8 parse-mode ; 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* From d0b348591a41e023fdc5576e52cb269d4f53e373 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 19 Mar 2008 19:15:43 -0500 Subject: [PATCH 091/886] path+, prepend --- core/bootstrap/stage2.factor | 2 +- core/classes/union/union.factor | 2 +- core/combinators/combinators.factor | 2 +- core/command-line/command-line.factor | 4 ++-- core/compiler/tests/intrinsics.factor | 2 +- core/generic/math/math.factor | 2 +- core/generic/standard/standard.factor | 4 ++-- core/io/files/files-docs.factor | 4 ++-- core/io/files/files.factor | 17 ++++++++++------- core/optimizer/specializers/specializers.factor | 2 +- core/sequences/sequences.factor | 2 ++ core/syntax/syntax.factor | 5 +++++ core/vocabs/loader/loader-tests.factor | 2 +- core/vocabs/loader/loader.factor | 10 +++++----- 14 files changed, 35 insertions(+), 25 deletions(-) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 63b5726ad7..2aeb3099ac 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -25,7 +25,7 @@ SYMBOL: bootstrap-time "exclude" "include" [ get-global " " split [ empty? not ] subset ] 2apply seq-diff - [ "bootstrap." swap append require ] each ; + [ "bootstrap." prepend require ] each ; : compile-remaining ( -- ) "Compiling remaining words..." print flush diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index dcc05e8160..c1c82d158b 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -13,7 +13,7 @@ PREDICATE: class union-class drop [ drop f ] ] [ unclip first "predicate" word-prop swap - [ >r "predicate" word-prop [ dup ] swap append r> ] + [ >r "predicate" word-prop [ dup ] prepend r> ] assoc-map alist>quot ] if ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index ffd1576e6e..53d18b53ca 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -80,7 +80,7 @@ M: hashtable hashcode* : 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? [ diff --git a/core/command-line/command-line.factor b/core/command-line/command-line.factor index ed4fb9f606..72c1e063e0 100644 --- a/core/command-line/command-line.factor +++ b/core/command-line/command-line.factor @@ -7,12 +7,12 @@ splitting io.files ; : 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 ; diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index dd9a453cfc..b854b4ef0d 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -385,7 +385,7 @@ cell 8 = [ [ 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 [ { byte-array } declare *char ] compile-call ] unit-test [ 156 ] [ -100 [ { byte-array } declare *uchar ] compile-call ] unit-test diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 9fd5481a39..b01fb87f72 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -53,7 +53,7 @@ TUPLE: no-math-method left right generic ; 2dup and [ 2dup math-upgrade >r math-class-max over order min-class applicable-method - r> swap append + r> prepend ] [ 2drop object-method ] if ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index c634e02e75..35161319ef 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -161,7 +161,7 @@ C: hook-combination 0 (dispatch#) [ swap slip hook-combination-var [ get ] curry - swap append + prepend ] with-variable ; inline M: hook-combination make-default-method @@ -170,7 +170,7 @@ M: hook-combination make-default-method M: hook-combination perform-combination [ standard-methods - [ [ drop ] swap append ] assoc-map + [ [ drop ] prepend ] assoc-map single-combination ] with-hook ; diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index df9c78fe47..1ee9d19e4a 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -19,7 +19,7 @@ ARTICLE: "pathnames" "Pathname manipulation" { $subsection parent-directory } { $subsection file-name } { $subsection last-path-separator } -{ $subsection path+ } +{ $subsection append-path } "Pathnames relative to Factor's install directory:" { $subsection resource-path } { $subsection ?resource-path } @@ -224,7 +224,7 @@ HELP: stat ( path -- directory? permissions length modified ) { stat exists? directory? } related-words -HELP: path+ +HELP: append-path { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } { $description "Concatenates two pathnames." } ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index a6320a7507..0d00197415 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -32,10 +32,13 @@ HOOK: rename-file io-backend ( from to -- ) : left-trim-separators ( str -- newstr ) [ path-separator? ] left-trim ; -: path+ ( str1 str2 -- str ) +: append-path ( str1 str2 -- str ) >r right-trim-separators "/" r> left-trim-separators 3append ; +: prepend-path ( str1 str2 -- str ) + swap append-path ; inline + : last-path-separator ( path -- n ? ) [ length 1- ] keep [ path-separator? ] find-last* ; @@ -119,7 +122,7 @@ HOOK: make-directory io-backend ( path -- ) : 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 ; @@ -127,7 +130,7 @@ HOOK: make-directory io-backend ( path -- ) 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 -- ) @@ -146,7 +149,7 @@ HOOK: delete-directory io-backend ( path -- ) : delete-tree ( path -- ) dup directory? (delete-tree) ; -: to-directory over file-name path+ ; +: to-directory over file-name append-path ; ! Moving and renaming files HOOK: move-file io-backend ( from to -- ) @@ -179,7 +182,7 @@ DEFER: copy-tree-into : copy-tree ( from to -- ) over directory? [ >r dup directory swap r> [ - >r swap first path+ r> copy-tree-into + >r swap first append-path r> copy-tree-into ] 2curry each ] [ copy-file @@ -194,7 +197,7 @@ DEFER: copy-tree-into ! Special paths : resource-path ( path -- newpath ) \ resource-path get [ image parent-directory ] unless* - swap path+ ; + prepend-path ; : ?resource-path ( path -- newpath ) "resource:" ?head [ resource-path ] when ; @@ -236,7 +239,7 @@ M: pathname <=> [ pathname-string ] compare ; [ dup make-directory ] when ; -: temp-file ( name -- path ) temp-directory swap path+ ; +: temp-file ( name -- path ) temp-directory prepend-path ; ! Home directory : home ( -- dir ) diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index 5153d84c7f..560a174289 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -35,7 +35,7 @@ IN: optimizer.specializers swap "method-class" word-prop add* ; : specialize-method ( quot method -- quot' ) - method-declaration [ declare ] curry swap append ; + method-declaration [ declare ] curry prepend ; : specialize-quot ( quot specializer -- quot' ) dup { number } = [ diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 9fc5264440..3c69bfa41c 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -299,6 +299,8 @@ 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 -- ) diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index d9870b08da..8cc9211599 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -163,6 +163,11 @@ IN: bootstrap.syntax [ construct-boa ] curry define-inline ] define-syntax + "ERROR:" [ + CREATE-CLASS dup ";" parse-tokens define-tuple-class + dup [ construct-boa throw ] curry define + ] define-syntax + "FORGET:" [ scan-word dup parsing? [ V{ } clone swap execute first ] when diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 0519096128..85399ca9e7 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -136,7 +136,7 @@ IN: vocabs.loader.tests [ { "2" "a" "b" "d" "e" "f" } [ - "vocabs.loader.test." swap append forget-vocab + "vocabs.loader.test." prepend forget-vocab ] each ] with-compilation-unit ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 9833b2834f..103b5290a4 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -25,7 +25,7 @@ V{ : vocab-dir? ( root name -- ? ) over [ - ".factor" vocab-dir+ path+ resource-exists? + ".factor" vocab-dir+ append-path resource-exists? ] [ 2drop f ] if ; @@ -39,14 +39,14 @@ H{ } clone root-cache set-global vocab-roots get swap [ vocab-dir? ] curry find nip ] cache ; -: vocab-path+ ( vocab path -- newpath ) - swap find-vocab-root dup [ swap path+ ] [ 2drop f ] if ; +: vocab-append-path ( vocab path -- newpath ) + swap find-vocab-root dup [ prepend-path ] [ 2drop f ] if ; : vocab-source-path ( vocab -- path/f ) - dup ".factor" vocab-dir+ vocab-path+ ; + dup ".factor" vocab-dir+ vocab-append-path ; : vocab-docs-path ( vocab -- path/f ) - dup "-docs.factor" vocab-dir+ vocab-path+ ; + dup "-docs.factor" vocab-dir+ vocab-append-path ; SYMBOL: load-help? From f5e678c3801cd33f0348ac67b631784c6cb6e250 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 19 Mar 2008 19:37:04 -0500 Subject: [PATCH 092/886] work on gmt-offset on windows --- extra/calendar/windows/windows.factor | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor index 9e34fdac00..acbae2fcd3 100755 --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -8,8 +8,14 @@ T{ windows-calendar } calendar-backend set-global : TIME_ZONE_ID_INVALID HEX: ffffffff ; inline -M: windows-calendar gmt-offset ( -- float ) +M: windows-calendar gmt-offset ( -- hours minutes seconds ) "TIME_ZONE_INFORMATION" - dup GetTimeZoneInformation - TIME_ZONE_ID_INVALID = [ win32-error ] when - TIME_ZONE_INFORMATION-Bias 60 / neg ; + dup GetTimeZoneInformation { + { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] } + { [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ] + [ TIME_ZONE_INFORMATION-Bias 60 / neg ] } + { [ dup TIME_ZONE_ID_DAYLIGHT = ] [ + [ TIME_ZONE_INFORMATION-Bias 60 / neg ] + [ TIME_ZONE_INFORMATION-DaylightBias ] bi + ] } + } cond ; From 264284d0c4dac5d6b70232fc1ff35b1bba0573c8 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 13:40:22 +1300 Subject: [PATCH 093/886] Add range-pattern parser --- extra/peg/parsers/parsers-docs.factor | 18 ++++++++++++++++ extra/peg/parsers/parsers.factor | 30 ++++++++++++++++++++++++++- 2 files changed, 47 insertions(+), 1 deletion(-) diff --git a/extra/peg/parsers/parsers-docs.factor b/extra/peg/parsers/parsers-docs.factor index 1991cba0eb..d49f1158dd 100755 --- a/extra/peg/parsers/parsers-docs.factor +++ b/extra/peg/parsers/parsers-docs.factor @@ -159,3 +159,21 @@ HELP: 'string' } { $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 ;" "\"a\" \"_a-zA-Z\" range-pattern parse parse-result-ast 1string ." "\"a\"" } + { $example "USING: peg peg.parsers prettyprint ;" "\"0\" \"^0-9\" range-pattern parse ." "f" } +} +} ; diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 87306e1469..63e9e9a336 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -2,7 +2,8 @@ ! 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 ; + unicode.categories sequences.deep peg peg.private + peg.search math.ranges ; IN: peg.parsers TUPLE: just-parser p1 ; @@ -83,3 +84,30 @@ MEMO: 'string' ( -- parser ) [ CHAR: " = not ] satisfy repeat0 , [ CHAR: " = ] satisfy hide , ] { } make 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 ; + +MEMO: 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 ; From 795ef0ae3b0a5031b329c84d555a1c64bfeae758 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 13:55:19 +1300 Subject: [PATCH 094/886] Add ranges to EBNF syntax This works: and --- extra/peg/ebnf/ebnf-tests.factor | 24 ++++++++++++++++++++++++ extra/peg/ebnf/ebnf.factor | 14 ++++++++++++++ 2 files changed, 38 insertions(+) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 8846a9c94c..458c68e0d4 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -118,4 +118,28 @@ IN: peg.ebnf.tests { V{ 1 2 } } [ "foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast +] unit-test + +{ CHAR: A } [ + "foo=[A-Z]" ebnf>quot with-compilation-unit "A" foo parse parse-result-ast +] unit-test + +{ CHAR: Z } [ + "foo=[A-Z]" ebnf>quot with-compilation-unit "Z" foo parse parse-result-ast +] unit-test + +{ f } [ + "foo=[A-Z]" ebnf>quot with-compilation-unit "0" foo parse +] unit-test + +{ CHAR: 0 } [ + "foo=[^A-Z]" ebnf>quot with-compilation-unit "0" foo parse parse-result-ast +] unit-test + +{ f } [ + "foo=[^A-Z]" ebnf>quot with-compilation-unit "A" foo parse +] unit-test + +{ f } [ + "foo=[^A-Z]" ebnf>quot with-compilation-unit "Z" foo parse ] unit-test \ No newline at end of file diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index e2c2dd5006..03f36c5f28 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -9,6 +9,7 @@ IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; TUPLE: ebnf-terminal symbol ; TUPLE: ebnf-any-character ; +TUPLE: ebnf-range pattern ; TUPLE: ebnf-ensure-not group ; TUPLE: ebnf-choice options ; TUPLE: ebnf-sequence elements ; @@ -22,6 +23,7 @@ TUPLE: ebnf rules ; C: ebnf-non-terminal C: ebnf-terminal C: ebnf-any-character +C: ebnf-range C: ebnf-ensure-not C: ebnf-choice C: ebnf-sequence @@ -69,6 +71,9 @@ M: ebnf-non-terminal (generate-parser) ( ast -- id ) M: ebnf-any-character (generate-parser) ( ast -- id ) drop [ drop t ] satisfy store-parser ; +M: ebnf-range (generate-parser) ( ast -- id ) + ebnf-range-pattern range-pattern store-parser ; + M: ebnf-choice (generate-parser) ( ast -- id ) ebnf-choice-options [ generate-parser get-parser @@ -163,6 +168,14 @@ DEFER: 'rhs' : 'any-character' ( -- parser ) #! A parser to match the symbol for any character match. [ CHAR: . = ] satisfy [ drop ] action ; + +: 'range-parser' ( -- parser ) + #! Match the syntax for declaring character ranges + [ + "[" syntax , + [ CHAR: ] = not ] satisfy repeat1 , + "]" syntax , + ] seq* [ first >string ] action ; : 'element' ( -- parser ) #! An element of a rule. It can be a terminal or a @@ -173,6 +186,7 @@ DEFER: 'rhs' [ 'non-terminal' , 'terminal' , + 'range-parser' , 'any-character' , ] choice* , "=" syntax ensure-not , From ec4f964e4f770f912cc9e1674bd790abcebc7f53 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 14:06:21 +1300 Subject: [PATCH 095/886] Fix pl0 for EBNF syntax changes --- extra/peg/pl0/pl0.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor index 1ef7a23b41..b30f6bfe70 100644 --- a/extra/peg/pl0/pl0.factor +++ b/extra/peg/pl0/pl0.factor @@ -16,16 +16,16 @@ MEMO: number ( -- parser ) =" | ">") expression -expression = ["+" | "-"] term {("+" | "-") term } -term = factor {("*" | "/") factor } +expression = ("+" | "-")? term (("+" | "-") term )* +term = factor (("*" | "/") factor )* factor = ident | number | "(" expression ")" EBNF> From 68388fbed90e0765925491d2ccc6ff3354bf7c0b Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 14:15:06 +1300 Subject: [PATCH 096/886] Updated peg.expr to use range-pattern for digits --- extra/peg/expr/expr-tests.factor | 25 +++++++++++++++++++++++++ extra/peg/expr/expr.factor | 5 ++--- 2 files changed, 27 insertions(+), 3 deletions(-) create mode 100644 extra/peg/expr/expr-tests.factor diff --git a/extra/peg/expr/expr-tests.factor b/extra/peg/expr/expr-tests.factor new file mode 100644 index 0000000000..0ed05765cd --- /dev/null +++ b/extra/peg/expr/expr-tests.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +! +USING: kernel tools.test peg.expr multiline sequences ; +IN: temporary + +{ 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 diff --git a/extra/peg/expr/expr.factor b/extra/peg/expr/expr.factor index ed13ac0e50..26ae76c0b0 100644 --- a/extra/peg/expr/expr.factor +++ b/extra/peg/expr/expr.factor @@ -16,9 +16,8 @@ divide = ("/") [[ drop [ / ] ]] add = ("+") [[ drop [ + ] ]] subtract = ("-") [[ drop [ - ] ]] -digit = "0" | "1" | "2" | "3" | "4" | - "5" | "6" | "7" | "8" | "9" -number = ((digit)+) [[ concat string>number ]] +digit = ([0-9]) [[ digit> ]] +number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]] value = number | ("(" expr ")") [[ second ]] product = (value ((times | divide) value)*) [[ first2 operator-fold ]] From 39c228db6d14ae9229d712abb716489248c3dca8 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 14:22:14 +1300 Subject: [PATCH 097/886] Update peg.pl0 to use range pattern syntax This allows removing the words for ident and number, replacing them with EBNF expressions. --- extra/peg/pl0/pl0.factor | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor index b30f6bfe70..34973e6a52 100644 --- a/extra/peg/pl0/pl0.factor +++ b/extra/peg/pl0/pl0.factor @@ -1,18 +1,10 @@ ! 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 namespaces ; +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 , - ] choice* repeat1 [ >string ] action ; - -MEMO: number ( -- parser ) - CHAR: 0 CHAR: 9 range repeat1 [ string>number ] action ; string ]] +digit = ([0-9]) [[ digit> ]] +number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]] EBNF> From c1f69f01beb2c6a183e42bd13b81a40374039baf Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 14:57:12 +1300 Subject: [PATCH 098/886] Change ordering of [[ ... ]] --- extra/peg/ebnf/ebnf-tests.factor | 20 ++++++++++---------- extra/peg/ebnf/ebnf.factor | 28 +++++++++++++++------------- extra/peg/expr/expr-tests.factor | 2 +- extra/peg/expr/expr.factor | 3 ++- 4 files changed, 28 insertions(+), 25 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 458c68e0d4..0989e4beb5 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel tools.test peg peg.ebnf compiler.units ; +USING: kernel parser words tools.test peg peg.ebnf compiler.units ; IN: peg.ebnf.tests { T{ ebnf-non-terminal f "abc" } } [ @@ -109,37 +109,37 @@ IN: peg.ebnf.tests ] unit-test { V{ "a" "b" } } [ - "foo='a' 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast + "foo='a' 'b'" ebnf>quot with-compilation-unit "ab" "foo" search execute parse parse-result-ast ] unit-test { V{ 1 "b" } } [ - "foo=('a')[[ drop 1 ]] 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast + "foo=('a')[[ drop 1 ]] 'b'" ebnf>quot with-compilation-unit "ab" "foo" search execute parse parse-result-ast ] unit-test { V{ 1 2 } } [ - "foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast + "foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" "foo" search execute parse parse-result-ast ] unit-test { CHAR: A } [ - "foo=[A-Z]" ebnf>quot with-compilation-unit "A" foo parse parse-result-ast + "foo=[A-Z]" ebnf>quot with-compilation-unit "A" "foo" search execute parse parse-result-ast ] unit-test { CHAR: Z } [ - "foo=[A-Z]" ebnf>quot with-compilation-unit "Z" foo parse parse-result-ast + "foo=[A-Z]" ebnf>quot with-compilation-unit "Z" "foo" search execute parse parse-result-ast ] unit-test { f } [ - "foo=[A-Z]" ebnf>quot with-compilation-unit "0" foo parse + "foo=[A-Z]" ebnf>quot with-compilation-unit "0" "foo" search execute parse ] unit-test { CHAR: 0 } [ - "foo=[^A-Z]" ebnf>quot with-compilation-unit "0" foo parse parse-result-ast + "foo=[^A-Z]" ebnf>quot with-compilation-unit "0" "foo" search execute parse parse-result-ast ] unit-test { f } [ - "foo=[^A-Z]" ebnf>quot with-compilation-unit "A" foo parse + "foo=[^A-Z]" ebnf>quot with-compilation-unit "A" "foo" search execute parse ] unit-test { f } [ - "foo=[^A-Z]" ebnf>quot with-compilation-unit "Z" foo parse + "foo=[^A-Z]" ebnf>quot with-compilation-unit "Z" "foo" search execute parse ] unit-test \ No newline at end of file diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 03f36c5f28..7d298a709d 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -172,7 +172,7 @@ DEFER: 'rhs' : 'range-parser' ( -- parser ) #! Match the syntax for declaring character ranges [ - "[" syntax , + [ "[" syntax , "[" token ensure-not , ] seq* hide , [ CHAR: ] = not ] satisfy repeat1 , "]" syntax , ] seq* [ first >string ] action ; @@ -208,7 +208,6 @@ DEFER: 'choice' "*" token sp ensure-not , "+" token sp ensure-not , "?" token sp ensure-not , - "[[" token sp ensure-not , ] seq* hide grouped ; : 'repeat0' ( -- parser ) @@ -226,13 +225,6 @@ DEFER: 'choice' [ drop t ] satisfy , ] seq* [ first ] action repeat0 [ >string ] action ; -: 'action' ( -- parser ) - [ - "(" [ 'choice' sp ] delay ")" syntax-pack , - "[[" 'factor-code' "]]" syntax-pack , - ] seq* [ first2 ] action ; - - : 'ensure-not' ( -- parser ) #! Parses the '!' syntax to ensure that #! something that matches the following elements do @@ -242,7 +234,7 @@ DEFER: 'choice' 'group' sp , ] seq* [ first ] action ; -: 'sequence' ( -- parser ) +: ('sequence') ( -- parser ) #! A sequence of terminals and non-terminals, including #! groupings of those. [ @@ -252,11 +244,21 @@ DEFER: 'choice' 'repeat0' sp , 'repeat1' sp , 'optional' sp , - 'action' sp , + ] choice* ; + +: 'sequence' ( -- parser ) + #! A sequence of terminals and non-terminals, including + #! groupings of those. + [ + [ + ('sequence') , + "[[" 'factor-code' "]]" syntax-pack , + ] seq* [ first2 ] action , + ('sequence') , ] choice* repeat1 [ dup length 1 = [ first ] [ ] if - ] action ; - + ] action ; + : 'choice' ( -- parser ) 'sequence' sp "|" token sp list-of [ dup length 1 = [ first ] [ ] if diff --git a/extra/peg/expr/expr-tests.factor b/extra/peg/expr/expr-tests.factor index 0ed05765cd..20da5cd16a 100644 --- a/extra/peg/expr/expr-tests.factor +++ b/extra/peg/expr/expr-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel tools.test peg.expr multiline sequences ; +USING: kernel tools.test peg peg.expr multiline sequences ; IN: temporary { 5 } [ diff --git a/extra/peg/expr/expr.factor b/extra/peg/expr/expr.factor index 26ae76c0b0..62ef4ea88f 100644 --- a/extra/peg/expr/expr.factor +++ b/extra/peg/expr/expr.factor @@ -26,4 +26,5 @@ expr = sum EBNF> : eval-expr ( string -- number ) - expr parse parse-result-ast ; \ No newline at end of file + expr parse parse-result-ast ; + From 6f2369b16ecf85a79eb0d4366e585222f451071d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 19 Mar 2008 21:15:38 -0500 Subject: [PATCH 099/886] add code to bootstrap.syntax --- core/bootstrap/syntax.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index a4e87f28d8..e7e90d8dd0 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -21,6 +21,7 @@ IN: bootstrap.syntax "C:" "CHAR:" "DEFER:" + "ERROR:" "F{" "FV{" "FORGET:" From 27e87292f04823d9b469634f83e9e07908041252 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 19 Mar 2008 21:16:09 -0500 Subject: [PATCH 100/886] Add [let* syntax --- extra/locals/locals-docs.factor | 21 +++- extra/locals/locals-tests.factor | 33 +++++++ extra/locals/locals.factor | 164 +++++++++++++++++++------------ 3 files changed, 152 insertions(+), 66 deletions(-) diff --git a/extra/locals/locals-docs.factor b/extra/locals/locals-docs.factor index 62f2eac513..372a567550 100644 --- a/extra/locals/locals-docs.factor +++ b/extra/locals/locals-docs.factor @@ -25,7 +25,7 @@ $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 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 ;" @@ -38,6 +38,24 @@ HELP: [let } $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" } "." } @@ -106,6 +124,7 @@ $nl { $subsection with-locals } "Lexical binding forms:" { $subsection POSTPONE: [let } +{ $subsection POSTPONE: [let* } { $subsection POSTPONE: [wlet } "Lambda abstractions:" { $subsection POSTPONE: [| } diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index bd1e62f22a..4ee9b48bb7 100755 --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -195,3 +195,36 @@ DEFER: xyzzy ] 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 + diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index a8f5e139e7..d7788c80bc 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -5,7 +5,7 @@ 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 ; +compiler.units combinators.cleave new-slots accessors ; IN: locals ! Inspired by @@ -17,11 +17,15 @@ TUPLE: lambda vars body ; C: lambda -TUPLE: let bindings vars body ; +TUPLE: let bindings body ; C: let -TUPLE: wlet bindings vars body ; +TUPLE: let* bindings body ; + +C: let* + +TUPLE: wlet bindings body ; C: wlet @@ -137,7 +141,7 @@ M: object free-vars drop { } ; M: quotation free-vars { } [ add-if-free ] reduce ; M: lambda free-vars - dup lambda-vars swap lambda-body free-vars seq-diff ; + dup vars>> swap body>> free-vars seq-diff ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! lambda-rewrite @@ -164,12 +168,12 @@ M: callable block-body ; 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 + dup vars>> swap body>> [ local-rewrite* \ call , ] [ ] make , ; M: block lambda-rewrite* @@ -187,24 +191,18 @@ M: object local-rewrite* , ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: make-locals ( seq -- words assoc ) - [ - "!" ?tail [ ] [ ] if - ] map dup [ - dup - [ dup word-name set ] each - [ - dup local-reader? [ - dup word-name set - ] [ - drop - ] if - ] each - ] H{ } make-assoc ; +: make-local ( name -- word ) + "!" ?tail [ + + dup dup word-name set + ] [ ] if + dup dup word-name set ; -: make-local-words ( seq -- words assoc ) - [ dup ] { } map>assoc - dup values swap ; +: make-locals ( seq -- words assoc ) + [ [ make-local ] map ] H{ } make-assoc ; + +: make-local-word ( name -- word ) + dup dup word-name set ; : push-locals ( assoc -- ) use get push ; @@ -213,41 +211,75 @@ M: object local-rewrite* , ; 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) ; + "|" parse-tokens make-locals dup push-locals + \ ] (parse-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 ; + +: 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 ) + [ + [ (parse-wbindings) ] H{ } make-assoc + dup push-locals + ] { } make swap ; + +: let-rewrite ( body bindings -- ) + [ + >r 1array r> spin [ call ] curry compose + ] assoc-each local-rewrite* \ call , ; M: let local-rewrite* - { let-bindings let-vars let-body } get-slots -rot - [ ] 2apply - [ - 1array -rot second -rot - [ call ] curry compose - ] 2each local-rewrite* \ call , ; + { body>> bindings>> } get-slots let-rewrite ; + +M: let* local-rewrite* + { body>> bindings>> } get-slots let-rewrite ; M: wlet local-rewrite* - dup wlet-bindings values over wlet-vars rot wlet-body - [ call ] curry compose local-rewrite* \ call , ; + { body>> bindings>> } get-slots + [ [ ] 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) @@ -263,14 +295,17 @@ PRIVATE> : [| parse-lambda parsed ; parsing : [let - parse-bindings - make-locals \ ] (parse-lambda) - parsed ; parsing + scan "|" assert= parse-bindings +\ ] (parse-lambda) parsed ; parsing + +: [let* + scan "|" assert= parse-bindings* + >r \ ] parse-until >quotation parsed r> pop-locals ; + parsing : [wlet - parse-bindings - make-local-words \ ] (parse-lambda) - parsed ; parsing + scan "|" assert= parse-wbindings + \ ] (parse-lambda) parsed ; parsing MACRO: with-locals ( form -- quot ) lambda-rewrite ; @@ -297,31 +332,30 @@ SYMBOL: | M: lambda pprint* > pprint-vars \ | pprint-word - f + f > pprint-elements block> \ ] pprint-word block> ; -: pprint-let ( body vars bindings -- ) +: pprint-let ( let word -- ) + pprint-word + { body>> bindings>> } get-slots \ | pprint-word t r pprint-var r> pprint* block> ] 2each + [ r pprint-var r> pprint* block> ] assoc-each block> \ | pprint-word - 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 "lambda" word-prop >boolean ; @@ -329,7 +363,7 @@ PREDICATE: word lambda-word M: lambda-word definer drop \ :: \ ; ; M: lambda-word definition - "lambda" word-prop lambda-body ; + "lambda" word-prop body>> ; : lambda-word-synopsis ( word -- ) dup definer. @@ -345,7 +379,7 @@ PREDICATE: macro lambda-macro 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 ; @@ -355,10 +389,10 @@ PREDICATE: method-body lambda-method 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 ; From 0d9947198ccc33ef92691f41ab111b7e446401b0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 19 Mar 2008 21:41:39 -0500 Subject: [PATCH 101/886] Bootstrap fixes --- core/compiler/tests/intrinsics.factor | 6 +-- core/heaps/heaps-tests.factor | 2 +- extra/bootstrap/random/random.factor | 6 ++- extra/calendar/calendar.factor | 40 +++++++++---------- extra/calendar/windows/windows.factor | 21 +++++----- extra/io/windows/nt/pipes/pipes.factor | 2 +- .../mersenne-twister/mersenne-twister.factor | 2 - extra/random/random.factor | 10 ++--- 8 files changed, 45 insertions(+), 44 deletions(-) mode change 100644 => 100755 extra/bootstrap/random/random.factor mode change 100644 => 100755 extra/random/random.factor diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index b854b4ef0d..7a8fe5d735 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -261,7 +261,7 @@ cell 8 = [ : 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 ; @@ -271,7 +271,7 @@ cell 8 = [ : 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 ; @@ -280,7 +280,7 @@ cell 8 = [ : 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 ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index 61e09d894e..0b3123c87b 100755 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -33,7 +33,7 @@ IN: heaps.tests : random-alist ( n -- alist ) [ [ - (random) dup number>string swap set + 32 random-bits dup number>string swap set ] times ] H{ } make-assoc ; diff --git a/extra/bootstrap/random/random.factor b/extra/bootstrap/random/random.factor old mode 100644 new mode 100755 index 7132860e1c..c4dc5dc660 --- a/extra/bootstrap/random/random.factor +++ b/extra/bootstrap/random/random.factor @@ -1,4 +1,5 @@ -USING: vocabs.loader sequences system ; +USING: vocabs.loader sequences system +random random.mersenne-twister ; "random.mersenne-twister" require @@ -6,3 +7,6 @@ USING: vocabs.loader sequences system ; { [ windows? ] [ "random.windows" require ] } { [ unix? ] [ "random.unix" require ] } } cond + +[ millis random-generator set-global ] +"generator.random" add-init-hook diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 457b0bea11..7347363e5b 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -59,31 +59,29 @@ SYMBOL: m 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 ; + [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 ) +:: 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 ; diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor index acbae2fcd3..1609b9f260 100755 --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -9,13 +9,14 @@ T{ windows-calendar } calendar-backend set-global : TIME_ZONE_ID_INVALID HEX: ffffffff ; inline M: windows-calendar gmt-offset ( -- hours minutes seconds ) - "TIME_ZONE_INFORMATION" - dup GetTimeZoneInformation { - { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] } - { [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ] - [ TIME_ZONE_INFORMATION-Bias 60 / neg ] } - { [ dup TIME_ZONE_ID_DAYLIGHT = ] [ - [ TIME_ZONE_INFORMATION-Bias 60 / neg ] - [ TIME_ZONE_INFORMATION-DaylightBias ] bi - ] } - } cond ; + 0 0 0 ; + ! "TIME_ZONE_INFORMATION" + ! dup GetTimeZoneInformation { + ! { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] } + ! { [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ] + ! [ TIME_ZONE_INFORMATION-Bias 60 / neg ] } + ! { [ dup TIME_ZONE_ID_DAYLIGHT = ] [ + ! [ TIME_ZONE_INFORMATION-Bias 60 / neg ] + ! [ TIME_ZONE_INFORMATION-DaylightBias ] bi + ! ] } + ! } cond ; diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor index eb6dae2a0a..6fd38e74b2 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -56,7 +56,7 @@ TUPLE: pipe in out ; "\\\\.\\pipe\\factor-" % pipe counter # "-" % - (random) # + 32 random-bits # "-" % millis # ] "" make ; diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index 79101c083e..c4e7cb2f7b 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -76,5 +76,3 @@ M: mersenne-twister random-32 ( mt -- r ) dup mt-n < [ drop 0 pick mt-generate ] unless new-nth mt-temper swap [ 1+ ] change-i drop ; - -[ millis \ random set-global ] "random" add-init-hook diff --git a/extra/random/random.factor b/extra/random/random.factor old mode 100644 new mode 100755 index bbf54e21eb..0d8b137fc5 --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -15,16 +15,14 @@ GENERIC: random-32 ( tuple -- r ) : (random-bytes) ( tuple n -- byte-array ) [ drop random-32 ] with map >c-uint-array ; -DEFER: random +SYMBOL: random-generator : random-bytes ( n -- r ) [ 4 /mod zero? [ 1+ ] unless - \ random get swap (random-bytes) + random-generator get swap (random-bytes) ] keep head ; -: random-bits ( n -- r ) 2^ random ; - : random ( seq -- elt ) dup empty? [ drop f @@ -35,5 +33,7 @@ DEFER: random ] keep nth ] if ; +: random-bits ( n -- r ) 2^ random ; + : with-random ( tuple quot -- ) - \ random swap with-variable ; inline + random-generator swap with-variable ; inline From e9d7e2523c35a64d2b172a20495118c4f40f8512 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 19 Mar 2008 21:48:29 -0500 Subject: [PATCH 102/886] Clean up random and fix circular --- core/bootstrap/stage2.factor | 2 +- extra/bootstrap/random/random.factor | 3 ++- extra/circular/circular-tests.factor | 6 ++++-- extra/circular/circular.factor | 4 ++-- extra/random/mersenne-twister/mersenne-twister-tests.factor | 5 ++--- extra/random/mersenne-twister/mersenne-twister.factor | 5 ++--- 6 files changed, 13 insertions(+), 12 deletions(-) mode change 100644 => 100755 extra/circular/circular-tests.factor mode change 100644 => 100755 extra/circular/circular.factor mode change 100644 => 100755 extra/random/mersenne-twister/mersenne-twister-tests.factor diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 2aeb3099ac..2523841aaf 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -57,7 +57,7 @@ millis >r default-image-name "output-image" set-global -"math help handbook compiler tools ui ui.tools io" "include" set-global +"math help handbook compiler random tools ui ui.tools io" "include" set-global "" "exclude" set-global parse-command-line diff --git a/extra/bootstrap/random/random.factor b/extra/bootstrap/random/random.factor index c4dc5dc660..b61e002526 100755 --- a/extra/bootstrap/random/random.factor +++ b/extra/bootstrap/random/random.factor @@ -1,5 +1,6 @@ USING: vocabs.loader sequences system -random random.mersenne-twister ; +random random.mersenne-twister combinators init +namespaces ; "random.mersenne-twister" require diff --git a/extra/circular/circular-tests.factor b/extra/circular/circular-tests.factor old mode 100644 new mode 100755 index 8ca4574885..9023ab1dba --- a/extra/circular/circular-tests.factor +++ b/extra/circular/circular-tests.factor @@ -9,7 +9,6 @@ circular strings ; [ CHAR: t ] [ "test" 0 swap nth ] unit-test [ "test" ] [ "test" >string ] unit-test -[ "test" 5 swap nth ] must-fail [ CHAR: e ] [ "test" 5 swap nth-unsafe ] unit-test [ [ 1 2 3 ] ] [ { 1 2 3 } [ ] like ] unit-test @@ -18,10 +17,13 @@ circular strings ; [ [ 3 1 2 ] ] [ { 1 2 3 } -100 over change-circular-start [ ] like ] unit-test [ "fob" ] [ "foo" CHAR: b 2 pick set-nth >string ] unit-test -[ "foo" CHAR: b 3 rot set-nth ] must-fail [ "boo" ] [ "foo" CHAR: b 3 pick set-nth-unsafe >string ] unit-test [ "ornact" ] [ "factor" 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test [ "bcd" ] [ 3 "abcd" [ over push-circular ] each >string ] unit-test [ { 0 0 } ] [ { 0 0 } -1 over change-circular-start >array ] unit-test + +! This no longer fails +! [ "test" 5 swap nth ] must-fail +! [ "foo" CHAR: b 3 rot set-nth ] must-fail diff --git a/extra/circular/circular.factor b/extra/circular/circular.factor old mode 100644 new mode 100755 index 8760e26586..08deb004e8 --- a/extra/circular/circular.factor +++ b/extra/circular/circular.factor @@ -18,9 +18,9 @@ M: circular length circular-seq length ; M: circular virtual@ circular-wrap circular-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 ; : change-circular-start ( n circular -- ) #! change start to (start + n) mod length diff --git a/extra/random/mersenne-twister/mersenne-twister-tests.factor b/extra/random/mersenne-twister/mersenne-twister-tests.factor old mode 100644 new mode 100755 index afd9d085b6..49bf4ad3f3 --- a/extra/random/mersenne-twister/mersenne-twister-tests.factor +++ b/extra/random/mersenne-twister/mersenne-twister-tests.factor @@ -1,7 +1,6 @@ USING: kernel math random namespaces random.mersenne-twister sequences tools.test ; IN: random.mersenne-twister.tests -USE: tools.walker : check-random ( max -- ? ) dup >r random 0 r> between? ; @@ -17,11 +16,11 @@ USE: tools.walker [ f ] [ 1234 [ make-100-randoms make-100-randoms = ] test-rng ] unit-test [ 1333075495 ] [ - 0 [ 1000 [ drop \ random get random-32 drop ] each \ random get random-32 ] test-rng + 0 [ 1000 [ drop random-generator get random-32 drop ] each random-generator get random-32 ] test-rng ] unit-test [ 1575309035 ] [ - 0 [ 10000 [ drop \ random get random-32 drop ] each \ random get random-32 ] test-rng + 0 [ 10000 [ drop random-generator get random-32 drop ] each random-generator get random-32 ] test-rng ] unit-test diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index c4e7cb2f7b..73f241a370 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -3,9 +3,8 @@ ! 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 new-slots accessors -math.ranges combinators.cleave circular random ; +USING: arrays kernel math namespaces sequences system init +new-slots accessors math.ranges combinators.cleave random ; IN: random.mersenne-twister Date: Thu, 20 Mar 2008 15:42:21 +1300 Subject: [PATCH 103/886] Refactor ebnf parser generation --- extra/peg/ebnf/ebnf.factor | 52 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 52 insertions(+) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 7d298a709d..c7a007bfc8 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -34,6 +34,55 @@ C: ebnf-rule C: ebnf-action C: ebnf +GENERIC: (transform) ( ast -- parser ) + +: transform ( ast -- object ) + H{ } clone dup dup [ "parser" set swap (transform) "main" set ] bind ; + +M: ebnf (transform) ( ast -- parser ) + ebnf-rules [ (transform) ] map peek ; + +M: ebnf-rule (transform) ( ast -- parser ) + dup ebnf-rule-elements (transform) [ + swap ebnf-rule-symbol set + ] keep ; + +M: ebnf-sequence (transform) ( ast -- parser ) + ebnf-sequence-elements [ (transform) ] map seq ; + +M: ebnf-choice (transform) ( ast -- parser ) + ebnf-choice-options [ (transform) ] map choice ; + +M: ebnf-any-character (transform) ( ast -- parser ) + drop any-char ; + +M: ebnf-range (transform) ( ast -- parser ) + ebnf-range-pattern range-pattern ; + +M: ebnf-ensure-not (transform) ( ast -- parser ) + ebnf-ensure-not-group (transform) ensure-not ; + +M: ebnf-repeat0 (transform) ( ast -- parser ) + ebnf-repeat0-group (transform) repeat0 ; + +M: ebnf-repeat1 (transform) ( ast -- parser ) + ebnf-repeat1-group (transform) repeat1 ; + +M: ebnf-optional (transform) ( ast -- parser ) + ebnf-optional-elements (transform) optional ; + +M: ebnf-action (transform) ( ast -- parser ) + [ ebnf-action-parser (transform) ] keep + ebnf-action-code string-lines parse-lines action ; + +M: ebnf-terminal (transform) ( ast -- parser ) + ebnf-terminal-symbol token sp ; + +M: ebnf-non-terminal (transform) ( ast -- parser ) + ebnf-non-terminal-symbol [ + , "parser" get , \ at , + ] [ ] make delay ; + SYMBOL: parsers SYMBOL: non-terminals @@ -295,4 +344,7 @@ DEFER: 'choice' f ] if* ; +: transform-ebnf ( string -- object ) + 'ebnf' parse parse-result-ast transform ; + : " parse-multiline-string ebnf>quot call ; parsing From e7980ebc616579df199cef126e11f33d42a243ec Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 17:11:09 +1300 Subject: [PATCH 104/886] More refactoring of EBNF now produces a quotation that when called does the parsing EBNF: foo ... ;EBNF creates a 'foo' word with stack effect (string -- result) when called it parses the string and returns the result. --- extra/peg/ebnf/ebnf-tests.factor | 20 +-- extra/peg/ebnf/ebnf.factor | 227 ++++++++++--------------------- extra/peg/expr/expr.factor | 7 +- extra/peg/pl0/pl0-tests.factor | 12 +- extra/peg/pl0/pl0.factor | 6 +- 5 files changed, 93 insertions(+), 179 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 0989e4beb5..6606fa9ffc 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel parser words tools.test peg peg.ebnf compiler.units ; +USING: kernel tools.test peg peg.ebnf ; IN: peg.ebnf.tests { T{ ebnf-non-terminal f "abc" } } [ @@ -109,37 +109,37 @@ IN: peg.ebnf.tests ] unit-test { V{ "a" "b" } } [ - "foo='a' 'b'" ebnf>quot with-compilation-unit "ab" "foo" search execute parse parse-result-ast + "ab" call parse-result-ast ] unit-test { V{ 1 "b" } } [ - "foo=('a')[[ drop 1 ]] 'b'" ebnf>quot with-compilation-unit "ab" "foo" search execute parse parse-result-ast + "ab" call parse-result-ast ] unit-test { V{ 1 2 } } [ - "foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" "foo" search execute parse parse-result-ast + "ab" call parse-result-ast ] unit-test { CHAR: A } [ - "foo=[A-Z]" ebnf>quot with-compilation-unit "A" "foo" search execute parse parse-result-ast + "A" call parse-result-ast ] unit-test { CHAR: Z } [ - "foo=[A-Z]" ebnf>quot with-compilation-unit "Z" "foo" search execute parse parse-result-ast + "Z" call parse-result-ast ] unit-test { f } [ - "foo=[A-Z]" ebnf>quot with-compilation-unit "0" "foo" search execute parse + "0" call ] unit-test { CHAR: 0 } [ - "foo=[^A-Z]" ebnf>quot with-compilation-unit "0" "foo" search execute parse parse-result-ast + "0" call parse-result-ast ] unit-test { f } [ - "foo=[^A-Z]" ebnf>quot with-compilation-unit "A" "foo" search execute parse + "A" call ] unit-test { f } [ - "foo=[^A-Z]" ebnf>quot with-compilation-unit "Z" "foo" search execute parse + "Z" call ] unit-test \ No newline at end of file diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index c7a007bfc8..b9f88f5f24 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel parser words arrays strings math.parser sequences +USING: kernel compiler.units parser words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg peg.parsers unicode.categories multiline combinators.lib splitting ; @@ -34,136 +34,6 @@ C: ebnf-rule C: ebnf-action C: ebnf -GENERIC: (transform) ( ast -- parser ) - -: transform ( ast -- object ) - H{ } clone dup dup [ "parser" set swap (transform) "main" set ] bind ; - -M: ebnf (transform) ( ast -- parser ) - ebnf-rules [ (transform) ] map peek ; - -M: ebnf-rule (transform) ( ast -- parser ) - dup ebnf-rule-elements (transform) [ - swap ebnf-rule-symbol set - ] keep ; - -M: ebnf-sequence (transform) ( ast -- parser ) - ebnf-sequence-elements [ (transform) ] map seq ; - -M: ebnf-choice (transform) ( ast -- parser ) - ebnf-choice-options [ (transform) ] map choice ; - -M: ebnf-any-character (transform) ( ast -- parser ) - drop any-char ; - -M: ebnf-range (transform) ( ast -- parser ) - ebnf-range-pattern range-pattern ; - -M: ebnf-ensure-not (transform) ( ast -- parser ) - ebnf-ensure-not-group (transform) ensure-not ; - -M: ebnf-repeat0 (transform) ( ast -- parser ) - ebnf-repeat0-group (transform) repeat0 ; - -M: ebnf-repeat1 (transform) ( ast -- parser ) - ebnf-repeat1-group (transform) repeat1 ; - -M: ebnf-optional (transform) ( ast -- parser ) - ebnf-optional-elements (transform) optional ; - -M: ebnf-action (transform) ( ast -- parser ) - [ ebnf-action-parser (transform) ] keep - ebnf-action-code string-lines parse-lines action ; - -M: ebnf-terminal (transform) ( ast -- parser ) - ebnf-terminal-symbol token sp ; - -M: ebnf-non-terminal (transform) ( ast -- parser ) - ebnf-non-terminal-symbol [ - , "parser" get , \ at , - ] [ ] make delay ; - -SYMBOL: parsers -SYMBOL: non-terminals - -: reset-parser-generation ( -- ) - V{ } clone parsers set - H{ } clone non-terminals set ; - -: store-parser ( parser -- number ) - parsers get [ push ] keep length 1- ; - -: get-parser ( index -- parser ) - parsers get nth ; - -: non-terminal-index ( name -- number ) - dup non-terminals get at [ - nip - ] [ - f store-parser [ swap non-terminals get set-at ] keep - ] if* ; - -GENERIC: (generate-parser) ( ast -- id ) - -: generate-parser ( ast -- id ) - (generate-parser) ; - -M: ebnf-terminal (generate-parser) ( ast -- id ) - ebnf-terminal-symbol token sp store-parser ; - -M: ebnf-non-terminal (generate-parser) ( ast -- id ) - [ - ebnf-non-terminal-symbol dup non-terminal-index , - parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or , - ] [ ] make delay sp store-parser ; - -M: ebnf-any-character (generate-parser) ( ast -- id ) - drop [ drop t ] satisfy store-parser ; - -M: ebnf-range (generate-parser) ( ast -- id ) - ebnf-range-pattern range-pattern store-parser ; - -M: ebnf-choice (generate-parser) ( ast -- id ) - ebnf-choice-options [ - generate-parser get-parser - ] map choice store-parser ; - -M: ebnf-sequence (generate-parser) ( ast -- id ) - ebnf-sequence-elements [ - generate-parser get-parser - ] map seq store-parser ; - -M: ebnf-ensure-not (generate-parser) ( ast -- id ) - ebnf-ensure-not-group generate-parser get-parser ensure-not store-parser ; - -M: ebnf-repeat0 (generate-parser) ( ast -- id ) - ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ; - -M: ebnf-repeat1 (generate-parser) ( ast -- id ) - ebnf-repeat1-group generate-parser get-parser repeat1 store-parser ; - -M: ebnf-optional (generate-parser) ( ast -- id ) - ebnf-optional-elements generate-parser get-parser optional store-parser ; - -M: ebnf-rule (generate-parser) ( ast -- id ) - dup ebnf-rule-symbol non-terminal-index swap - ebnf-rule-elements generate-parser get-parser ! nt-id body - swap [ parsers get set-nth ] keep ; - -M: ebnf-action (generate-parser) ( ast -- id ) - [ ebnf-action-parser generate-parser get-parser ] keep - ebnf-action-code string-lines parse-lines action store-parser ; - -M: vector (generate-parser) ( ast -- id ) - [ generate-parser ] map peek ; - -M: ebnf (generate-parser) ( ast -- id ) - ebnf-rules [ - generate-parser - ] map peek ; - -DEFER: 'rhs' - : syntax ( string -- parser ) #! Parses the string, ignoring white space, and #! does not put the result in the AST. @@ -323,28 +193,81 @@ DEFER: 'choice' : 'ebnf' ( -- parser ) 'rule' sp repeat1 [ ] action ; -: ebnf>quot ( string -- quot ) - 'ebnf' parse [ - parse-result-ast [ - reset-parser-generation - generate-parser drop - [ - non-terminals get - [ - get-parser [ - swap , \ in , \ get , \ create , - 1quotation , \ define , - ] [ - drop - ] if* - ] assoc-each - ] [ ] make - ] with-scope - ] [ - f - ] if* ; +GENERIC: (transform) ( ast -- parser ) + +SYMBOL: parser +SYMBOL: main + +: transform ( ast -- object ) + H{ } clone dup dup [ parser set swap (transform) main set ] bind ; + +M: ebnf (transform) ( ast -- parser ) + ebnf-rules [ (transform) ] map peek ; + +M: ebnf-rule (transform) ( ast -- parser ) + dup ebnf-rule-elements (transform) [ + swap ebnf-rule-symbol set + ] keep ; + +M: ebnf-sequence (transform) ( ast -- parser ) + ebnf-sequence-elements [ (transform) ] map seq ; + +M: ebnf-choice (transform) ( ast -- parser ) + ebnf-choice-options [ (transform) ] map choice ; + +M: ebnf-any-character (transform) ( ast -- parser ) + drop any-char ; + +M: ebnf-range (transform) ( ast -- parser ) + ebnf-range-pattern range-pattern ; + +M: ebnf-ensure-not (transform) ( ast -- parser ) + ebnf-ensure-not-group (transform) ensure-not ; + +M: ebnf-repeat0 (transform) ( ast -- parser ) + ebnf-repeat0-group (transform) repeat0 ; + +M: ebnf-repeat1 (transform) ( ast -- parser ) + ebnf-repeat1-group (transform) repeat1 ; + +M: ebnf-optional (transform) ( ast -- parser ) + ebnf-optional-elements (transform) optional ; + +M: ebnf-action (transform) ( ast -- parser ) + [ ebnf-action-parser (transform) ] keep + ebnf-action-code string-lines [ parse-lines ] with-compilation-unit action ; + +M: ebnf-terminal (transform) ( ast -- parser ) + ebnf-terminal-symbol token sp ; + +M: ebnf-non-terminal (transform) ( ast -- parser ) + ebnf-non-terminal-symbol [ + , parser get , \ at , + ] [ ] make delay sp ; : transform-ebnf ( string -- object ) 'ebnf' parse parse-result-ast transform ; -: " parse-multiline-string ebnf>quot call ; parsing +: check-parse-result ( result -- result ) + dup [ + dup parse-result-remaining empty? [ + [ + "Unable to fully parse EBNF. Left to parse was: " % + parse-result-remaining % + ] "" make throw + ] unless + ] [ + "Could not parse EBNF" throw + ] if ; + +: ebnf>quot ( string -- hashtable quot ) + 'ebnf' parse check-parse-result + parse-result-ast transform dup main swap at compile ; + +: " parse-multiline-string ebnf>quot nip parsed ; parsing + +: EBNF: + CREATE-WORD dup + ";EBNF" parse-multiline-string + ebnf>quot swapd define "ebnf-parser" set-word-prop ; parsing + diff --git a/extra/peg/expr/expr.factor b/extra/peg/expr/expr.factor index 62ef4ea88f..14f0e7c14e 100644 --- a/extra/peg/expr/expr.factor +++ b/extra/peg/expr/expr.factor @@ -9,8 +9,7 @@ IN: peg.expr #! { operator rhs } in to a tree structure of the correct precedence. swap [ first2 swap call ] reduce ; - +;EBNF : eval-expr ( string -- number ) - expr parse parse-result-ast ; + expr parse-result-ast ; diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor index bf321d54e9..b3d2135da7 100644 --- a/extra/peg/pl0/pl0-tests.factor +++ b/extra/peg/pl0/pl0-tests.factor @@ -4,14 +4,6 @@ USING: kernel tools.test peg peg.pl0 multiline sequences ; IN: peg.pl0.tests -{ "abc" } [ - "abc" ident parse parse-result-ast -] unit-test - -{ 55 } [ - "55abc" number parse parse-result-ast -] unit-test - { t } [ <" VAR x, squ; @@ -29,7 +21,7 @@ BEGIN x := x + 1; END END. -"> program parse parse-result-remaining empty? +"> pl0 parse-result-remaining empty? ] unit-test { f } [ @@ -95,5 +87,5 @@ BEGIN y := 36; CALL gcd; END. - "> program parse parse-result-remaining empty? + "> pl0 parse-result-remaining empty? ] unit-test \ No newline at end of file diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor index 34973e6a52..f7eb3cad23 100644 --- a/extra/peg/pl0/pl0.factor +++ b/extra/peg/pl0/pl0.factor @@ -6,8 +6,7 @@ IN: peg.pl0 #! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0 -string ]] digit = ([0-9]) [[ digit> ]] number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]] -EBNF> +program = block "." +;EBNF From 44954753bdc0cdc593b6c8e8abd8efd8e4759ed0 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 17:13:27 +1300 Subject: [PATCH 105/886] Change to [EBNF .. EBNF] --- extra/peg/ebnf/ebnf-tests.factor | 18 +++++++++--------- extra/peg/ebnf/ebnf.factor | 2 +- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 6606fa9ffc..54639431a4 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -109,37 +109,37 @@ IN: peg.ebnf.tests ] unit-test { V{ "a" "b" } } [ - "ab" call parse-result-ast + "ab" [EBNF foo='a' 'b' EBNF] call parse-result-ast ] unit-test { V{ 1 "b" } } [ - "ab" call parse-result-ast + "ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF] call parse-result-ast ] unit-test { V{ 1 2 } } [ - "ab" call parse-result-ast + "ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF] call parse-result-ast ] unit-test { CHAR: A } [ - "A" call parse-result-ast + "A" [EBNF foo=[A-Z] EBNF] call parse-result-ast ] unit-test { CHAR: Z } [ - "Z" call parse-result-ast + "Z" [EBNF foo=[A-Z] EBNF] call parse-result-ast ] unit-test { f } [ - "0" call + "0" [EBNF foo=[A-Z] EBNF] call ] unit-test { CHAR: 0 } [ - "0" call parse-result-ast + "0" [EBNF foo=[^A-Z] EBNF] call parse-result-ast ] unit-test { f } [ - "A" call + "A" [EBNF foo=[^A-Z] EBNF] call ] unit-test { f } [ - "Z" call + "Z" [EBNF foo=[^A-Z] EBNF] call ] unit-test \ No newline at end of file diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index b9f88f5f24..caa1800297 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -264,7 +264,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) 'ebnf' parse check-parse-result parse-result-ast transform dup main swap at compile ; -: " parse-multiline-string ebnf>quot nip parsed ; parsing +: [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing : EBNF: CREATE-WORD dup From 8ade4f9b5b90b10fba1546bdb75d876356152129 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 17:16:50 +1300 Subject: [PATCH 106/886] Fix vocab name in expr tests --- extra/peg/expr/expr-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/peg/expr/expr-tests.factor b/extra/peg/expr/expr-tests.factor index 20da5cd16a..b6f3163bf4 100644 --- a/extra/peg/expr/expr-tests.factor +++ b/extra/peg/expr/expr-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel tools.test peg peg.expr multiline sequences ; -IN: temporary +IN: peg.expr.tests { 5 } [ "2+3" eval-expr From dbd0583044940c4765caae207ef1e41f02e88994 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 17:19:41 +1300 Subject: [PATCH 107/886] Tidy up expr groups --- extra/peg/expr/expr.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/peg/expr/expr.factor b/extra/peg/expr/expr.factor index 14f0e7c14e..6b690cb5ee 100644 --- a/extra/peg/expr/expr.factor +++ b/extra/peg/expr/expr.factor @@ -10,13 +10,13 @@ IN: peg.expr swap [ first2 swap call ] reduce ; EBNF: expr -times = ("*") [[ drop [ * ] ]] -divide = ("/") [[ drop [ / ] ]] -add = ("+") [[ drop [ + ] ]] -subtract = ("-") [[ drop [ - ] ]] +times = "*" [[ drop [ * ] ]] +divide = "/" [[ drop [ / ] ]] +add = "+" [[ drop [ + ] ]] +subtract = "-" [[ drop [ - ] ]] -digit = ([0-9]) [[ digit> ]] -number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]] +digit = [0-9] [[ digit> ]] +number = (digit)+ [[ unclip [ swap 10 * + ] reduce ]] value = number | ("(" expr ")") [[ second ]] product = (value ((times | divide) value)*) [[ first2 operator-fold ]] From d1e7ede35dc37c14bf3c28814fab0f0d47d18e7f Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Mar 2008 17:25:27 +1300 Subject: [PATCH 108/886] Add support for & syntax in ebnf --- extra/peg/ebnf/ebnf.factor | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index caa1800297..ab7baa547e 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -10,6 +10,7 @@ TUPLE: ebnf-non-terminal symbol ; TUPLE: ebnf-terminal symbol ; TUPLE: ebnf-any-character ; TUPLE: ebnf-range pattern ; +TUPLE: ebnf-ensure group ; TUPLE: ebnf-ensure-not group ; TUPLE: ebnf-choice options ; TUPLE: ebnf-sequence elements ; @@ -24,6 +25,7 @@ C: ebnf-non-terminal C: ebnf-terminal C: ebnf-any-character C: ebnf-range +C: ebnf-ensure C: ebnf-ensure-not C: ebnf-choice C: ebnf-sequence @@ -73,6 +75,7 @@ C: ebnf [ dup CHAR: [ = ] [ dup CHAR: . = ] [ dup CHAR: ! = ] + [ dup CHAR: & = ] [ dup CHAR: * = ] [ dup CHAR: + = ] [ dup CHAR: ? = ] @@ -153,11 +156,21 @@ DEFER: 'choice' 'group' sp , ] seq* [ first ] action ; +: 'ensure' ( -- parser ) + #! Parses the '&' syntax to ensure that + #! something that matches the following elements does + #! exist in the parse stream. + [ + "&" syntax , + 'group' sp , + ] seq* [ first ] action ; + : ('sequence') ( -- parser ) #! A sequence of terminals and non-terminals, including #! groupings of those. [ 'ensure-not' sp , + 'ensure' sp , 'element' sp , 'group' sp , 'repeat0' sp , @@ -221,6 +234,9 @@ M: ebnf-any-character (transform) ( ast -- parser ) M: ebnf-range (transform) ( ast -- parser ) ebnf-range-pattern range-pattern ; +M: ebnf-ensure (transform) ( ast -- parser ) + ebnf-ensure-group (transform) ensure ; + M: ebnf-ensure-not (transform) ( ast -- parser ) ebnf-ensure-not-group (transform) ensure-not ; From aec6d6f5c88955d6e967c7a64d7a63fb0c413e2a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 19 Mar 2008 23:29:19 -0500 Subject: [PATCH 109/886] Replace (stat) with (exists?) --- core/bootstrap/primitives.factor | 5 ++- core/io/files/files-docs.factor | 14 +------ core/io/files/files.factor | 11 ++---- vm/io.h | 2 +- vm/os-unix.c | 18 +-------- vm/os-windows.c | 65 +++++++++++--------------------- vm/primitives.c | 2 +- 7 files changed, 36 insertions(+), 81 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index e407bfd143..354ea672eb 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -91,8 +91,9 @@ call } [ create-vocab drop ] each H{ } clone source-files set -H{ } clone class } " and " { $link } ", to prepare a pathname before passing it to underlying code." } ; +{ $description "Called by words such as " { $link } " and " { $link } " to prepare a pathname before passing it to underlying code." } ; HELP: ( str -- pathname ) { $values { "str" "a pathname string" } { "pathname" pathname } } diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 0d00197415..3de7559303 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -86,14 +86,11 @@ SYMBOL: +socket+ SYMBOL: +unknown+ ! File metadata -: stat ( path -- directory? permissions length modified ) - normalize-pathname (stat) ; +: exists? ( path -- ? ) + normalize-pathname (exists?) ; -: file-modified ( path -- n ) stat >r 3drop r> ; - -: exists? ( path -- ? ) file-modified >boolean ; - -: directory? ( path -- ? ) file-info file-info-type +directory+ = ; +: directory? ( path -- ? ) + file-info file-info-type +directory+ = ; ! Current working directory HOOK: cd io-backend ( path -- ) diff --git a/vm/io.h b/vm/io.h index a19da3887c..6291db50ee 100755 --- a/vm/io.h +++ b/vm/io.h @@ -12,5 +12,5 @@ DECLARE_PRIMITIVE(fclose); /* Platform specific primitives */ DECLARE_PRIMITIVE(open_file); -DECLARE_PRIMITIVE(stat); +DECLARE_PRIMITIVE(existsp); DECLARE_PRIMITIVE(read_dir); diff --git a/vm/os-unix.c b/vm/os-unix.c index 37dceb0d37..29d53487a3 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -41,24 +41,10 @@ void ffi_dlclose(F_DLL *dll) 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 */ diff --git a/vm/os-windows.c b/vm/os-windows.c index f9b80ea32a..1be41f8b57 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -87,14 +87,6 @@ const F_CHAR *vm_executable_path(void) 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 @@ -102,56 +94,45 @@ void find_file_stat(F_CHAR *path) 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); } diff --git a/vm/primitives.c b/vm/primitives.c index d1d956dca0..ce26c20f63 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -88,7 +88,7 @@ void *primitives[] = { primitive_eq, primitive_getenv, primitive_setenv, - primitive_stat, + primitive_existsp, primitive_read_dir, primitive_data_gc, primitive_code_gc, From 1ba4294bb230a71ee39b33e451398f76e667a309 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 19 Mar 2008 23:29:35 -0500 Subject: [PATCH 110/886] Update smtp for random changes --- extra/smtp/smtp.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index f7cdf9e64d..e15a90eda9 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -125,7 +125,7 @@ M: email clone : message-id ( -- string ) [ "<" % - 2 big-random # + 64 random-bits # "-" % millis # "@" % From 70641c9293b9ccbb40c1101f9642a264cbf5f504 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 19 Mar 2008 23:29:59 -0500 Subject: [PATCH 111/886] Fix failing classes unit tests --- core/bootstrap/image/image.factor | 2 +- core/classes/classes.factor | 37 ++++++++++++++++++++++++++----- 2 files changed, 33 insertions(+), 6 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index f5f4d70d14..52a2496755 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -349,7 +349,7 @@ M: curry ' [ { dictionary source-files - typemap builtins classboolean ; { [ dup builtin-class? ] [ dup set ] } { [ dup members ] [ members [ (flatten-class) ] each ] } { [ dup superclass ] [ superclass (flatten-class) ] } + { [ t ] [ drop ] } } cond ; : flatten-class ( class -- assoc ) @@ -108,11 +110,29 @@ DEFER: (class<) : lookup-union ( classes -- class ) typemap get at dup empty? [ drop object ] [ first ] if ; +: lookup-tuple-union ( classes -- class ) + class-map 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 ; + +: class-or-fixup ( set set -- set ) + union + tuple over key? + [ [ drop tuple-class? not ] assoc-subset ] when ; + : (class-or) ( class class -- class ) - [ flatten-builtin-class ] 2apply union lookup-union ; + [ flatten-class ] 2apply class-or-fixup lookup-tuple-union ; + +: class-and-fixup ( set set -- set ) + 2dup [ tuple swap key? ] either? + [ 2drop H{ { tuple tuple } } ] [ intersect ] if ; : (class-and) ( class class -- class ) - [ flatten-builtin-class ] 2apply intersect lookup-union ; + [ flatten-class ] 2apply class-and-fixup lookup-tuple-union ; : tuple-class-and ( class1 class2 -- class ) dupd eq? [ drop null ] unless ; @@ -219,9 +239,16 @@ M: word reset-class drop ; : typemap- ( class -- ) dup flatten-builtin-class typemap get pop-at ; +! class-map +: class-map+ ( class -- ) + dup flatten-class class-map get push-at ; + +: class-map- ( class -- ) + dup flatten-class class-map get pop-at ; + ! Class definition : cache-class ( class -- ) - dup typemap+ dup class Date: Wed, 19 Mar 2008 23:58:47 -0500 Subject: [PATCH 112/886] Fixes --- core/classes/classes-tests.factor | 2 ++ core/classes/classes.factor | 12 +++++++----- core/inference/known-words/known-words.factor | 2 +- 3 files changed, 10 insertions(+), 6 deletions(-) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index f97f088845..3322c3b043 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -22,6 +22,8 @@ H{ } "s" set [ number ] [ number object class-and ] unit-test [ number ] [ object number class-and ] unit-test [ null ] [ slice reversed class-and ] unit-test +[ null ] [ general-t \ f class-and ] unit-test +[ object ] [ general-t \ f class-or ] unit-test TUPLE: first-one ; TUPLE: second-one ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index ad2920e594..e47dbd20e5 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -127,12 +127,14 @@ DEFER: (class<) : (class-or) ( class class -- class ) [ flatten-class ] 2apply class-or-fixup lookup-tuple-union ; -: class-and-fixup ( set set -- set ) - 2dup [ tuple swap key? ] either? - [ 2drop H{ { tuple tuple } } ] [ intersect ] if ; - : (class-and) ( class class -- class ) - [ flatten-class ] 2apply class-and-fixup lookup-tuple-union ; + 2dup [ tuple swap class< ] either? [ + [ flatten-builtin-class ] 2apply + intersect lookup-union + ] [ + [ flatten-class ] 2apply + intersect lookup-tuple-union + ] if ; : tuple-class-and ( class1 class2 -- class ) dupd eq? [ drop null ] unless ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 235c2924bb..08fb56ced7 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -354,7 +354,7 @@ M: object infer-call \ setenv { object fixnum } { } set-primitive-effect -\ (stat) { string } { object object object object } set-primitive-effect +\ exists? { string } { object } set-primitive-effect \ (directory) { string } { array } set-primitive-effect From 7084e1982e38e558e2d19c867faec2b967e40eb8 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 19 Mar 2008 23:33:17 -0600 Subject: [PATCH 113/886] builder: update timeout to 2 hours --- extra/builder/builder.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index ea404d6efa..19734a3266 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -86,7 +86,7 @@ IN: builder +closed+ >>stdin "../test-log" >>stdout +stdout+ >>stderr - 45 minutes >>timeout ; + 120 minutes >>timeout ; : do-builder-test ( -- ) builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ; From 0c490161b4241a69e70ac686032905d08bd0c9e0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 00:39:32 -0500 Subject: [PATCH 114/886] Fix exists? --- vm/os-unix.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/os-unix.c b/vm/os-unix.c index 29d53487a3..74320288aa 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -44,7 +44,7 @@ void ffi_dlclose(F_DLL *dll) DEFINE_PRIMITIVE(existsp) { struct stat sb; - box_boolean(stat(unbox_char_string(),&sb) < 0); + box_boolean(stat(unbox_char_string(),&sb) >= 0); } /* Allocates memory */ From 1c6882b32cc54d57c36296168e4db339a86560c3 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 21 Mar 2008 01:25:45 +1300 Subject: [PATCH 115/886] Rip out packrat stuff It was broken since the transition to generating compiled quotations. As far as I know, no one was using packrat-parse anyway. Rework in progress... --- extra/peg/parsers/parsers.factor | 38 +++++------ extra/peg/peg-tests.factor | 4 -- extra/peg/peg.factor | 106 ++++++++----------------------- 3 files changed, 44 insertions(+), 104 deletions(-) diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 63e9e9a336..3ccb1e7d10 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -1,7 +1,7 @@ ! 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 + vectors arrays combinators.lib math.parser match unicode.categories sequences.deep peg peg.private peg.search math.ranges ; IN: peg.parsers @@ -19,26 +19,26 @@ TUPLE: just-parser p1 ; M: just-parser compile ( parser -- quot ) just-parser-p1 compile just-pattern append ; -MEMO: just ( parser -- parser ) - just-parser construct-boa init-parser ; +: just ( parser -- parser ) + just-parser construct-boa ; -MEMO: 1token ( ch -- parser ) 1string token ; +: 1token ( ch -- parser ) 1string token ; 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 ; -MEMO: exactly-n ( parser n -- parser' ) +: exactly-n ( parser n -- parser' ) swap seq ; -MEMO: at-most-n ( parser n -- parser' ) +: at-most-n ( parser n -- parser' ) dup zero? [ 2drop epsilon ] [ @@ -58,27 +58,27 @@ MEMO: at-most-n ( parser n -- parser' ) -rot 1- at-most-n 2choice ] if ; -MEMO: at-least-n ( parser n -- parser' ) +: at-least-n ( parser n -- parser' ) dupd exactly-n swap repeat0 2seq [ flatten-vectors ] action ; -MEMO: from-m-to-n ( parser m n -- parser' ) +: from-m-to-n ( parser m n -- parser' ) >r [ exactly-n ] 2keep r> swap - at-most-n 2seq [ flatten-vectors ] action ; -MEMO: pack ( begin body end -- parser ) +: pack ( begin body end -- parser ) >r >r hide r> r> hide 3seq [ first ] action ; -MEMO: surrounded-by ( parser begin end -- parser' ) +: surrounded-by ( parser begin end -- parser' ) [ token ] 2apply 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 , @@ -97,7 +97,7 @@ MEMO: 'string' ( -- parser ) ] action replace ; -MEMO: range-pattern ( pattern -- parser ) +: 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 diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index 7a1ce99883..89cc243863 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -4,10 +4,6 @@ USING: kernel tools.test strings namespaces arrays sequences peg peg.private ; 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 diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 16cf40f884..b3200ec5eb 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 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 + vectors arrays combinators.lib math.parser match unicode.categories sequences.lib compiler.units parser words ; IN: peg @@ -10,70 +10,14 @@ TUPLE: parse-result remaining ast ; GENERIC: compile ( parser -- quot ) -: (parse) ( state parser -- result ) +: parse ( state parser -- result ) compile call ; - - ( remaining ast -- parse-result ) parse-result construct-boa ; -SYMBOL: next-id - -: get-next-id ( -- number ) - next-id get-global 0 or dup 1+ next-id set-global ; - -TUPLE: parser id ; - -: init-parser ( parser -- parser ) - get-next-id parser construct-boa over set-delegate ; - -: from ( slice-or-string -- index ) - 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 ; - -: put-cached ( result input parser -- ) - parser-id dup packrat-cache get at [ - nip - ] [ - H{ } clone dup >r swap packrat-cache get set-at r> - ] if* - [ from ] dip set-at ; - -PRIVATE> - -: 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 - ] if - ] [ - (parse) - ] if ; - -: packrat-parse ( input parser -- result ) - H{ } clone packrat-cache [ parse ] with-variable ; - -MEMO: token ( string -- parser ) - token-parser construct-boa init-parser ; +: token ( string -- parser ) + token-parser construct-boa ; : satisfy ( quot -- parser ) - satisfy-parser construct-boa init-parser ; + satisfy-parser construct-boa ; -MEMO: range ( min max -- parser ) - range-parser construct-boa init-parser ; +: range ( min max -- parser ) + range-parser construct-boa ; : seq ( seq -- parser ) - seq-parser construct-boa init-parser ; + seq-parser construct-boa ; : 2seq ( parser1 parser2 -- parser ) 2array seq ; @@ -320,7 +264,7 @@ MEMO: range ( min max -- parser ) { } make seq ; inline : choice ( seq -- parser ) - choice-parser construct-boa init-parser ; + choice-parser construct-boa ; : 2choice ( parser1 parser2 -- parser ) 2array choice ; @@ -334,32 +278,32 @@ MEMO: range ( min max -- parser ) : choice* ( quot -- paser ) { } make choice ; inline -MEMO: repeat0 ( parser -- parser ) - repeat0-parser construct-boa init-parser ; +: repeat0 ( parser -- parser ) + repeat0-parser construct-boa ; -MEMO: repeat1 ( parser -- parser ) - repeat1-parser construct-boa init-parser ; +: repeat1 ( parser -- parser ) + repeat1-parser construct-boa ; -MEMO: optional ( parser -- parser ) - optional-parser construct-boa init-parser ; +: optional ( parser -- parser ) + optional-parser construct-boa ; -MEMO: ensure ( parser -- parser ) - ensure-parser construct-boa init-parser ; +: ensure ( parser -- parser ) + ensure-parser construct-boa ; -MEMO: ensure-not ( parser -- parser ) - ensure-not-parser construct-boa init-parser ; +: ensure-not ( parser -- parser ) + ensure-not-parser construct-boa ; : action ( parser quot -- parser ) - action-parser construct-boa init-parser ; + action-parser construct-boa ; -MEMO: sp ( parser -- parser ) - sp-parser construct-boa init-parser ; +: sp ( parser -- parser ) + sp-parser construct-boa ; -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 construct-boa ; : PEG: (:) [ From a14854520da6b9c41ee0f0aeb9235fa9d894129a Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 21 Mar 2008 03:05:21 +1300 Subject: [PATCH 116/886] Compile pegs down to words --- extra/peg/parsers/parsers.factor | 6 +- extra/peg/peg.factor | 124 +++++++++++++++++++------------ 2 files changed, 78 insertions(+), 52 deletions(-) diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 3ccb1e7d10..407729004f 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -16,11 +16,11 @@ TUPLE: just-parser p1 ; ] ; -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 ; : just ( parser -- parser ) - just-parser construct-boa ; + just-parser construct-boa init-parser ; : 1token ( ch -- parser ) 1string token ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index b3200ec5eb..9d6b18398e 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -8,16 +8,42 @@ IN: peg TUPLE: parse-result remaining ast ; -GENERIC: compile ( parser -- quot ) - -: parse ( state parser -- result ) - compile call ; - SYMBOL: ignore : ( remaining ast -- parse-result ) parse-result construct-boa ; +TUPLE: parser ; +C: parser +M: parser equal? eq? ; + +: init-parser ( parser -- parser ) + #! Set the delegate for the parser + over set-delegate ; + +SYMBOL: compiled-parsers + +GENERIC: (compile) ( parser -- quot ) + +: compiled-parser ( parser -- word ) + #! Look to see if the given parser has been compied. + #! If not, compile it to a temporary word, cache it, + #! and return it. Otherwise return the existing one. + dup compiled-parsers get at [ + nip + ] [ + dup (compile) define-temp + [ swap compiled-parsers get set-at ] keep + ] if* ; + +: compile ( parser -- word ) + H{ } clone compiled-parsers [ + [ compiled-parser ] with-compilation-unit + ] with-variable ; + +: parse ( state parser -- result ) + compile call ; + ] % - seq-parser-parsers [ compile \ ?quot seq-pattern match-replace % ] each + seq-parser-parsers [ compiled-parser \ ?quot seq-pattern match-replace % ] each ] [ ] make ; TUPLE: choice-parser parsers ; @@ -110,14 +136,14 @@ TUPLE: choice-parser parsers ; dup [ ] [ - drop dup ?quot call + drop dup ?quot ] if ] ; -M: choice-parser compile ( parser -- quot ) +M: choice-parser (compile) ( parser -- quot ) [ f , - choice-parser-parsers [ compile \ ?quot choice-pattern match-replace % ] each + choice-parser-parsers [ compiled-parser \ ?quot choice-pattern match-replace % ] each \ nip , ] [ ] make ; @@ -134,20 +160,20 @@ TUPLE: repeat0-parser p1 ; : repeat0-pattern ( -- quot ) [ - ?quot swap (repeat0) + [ ?quot ] swap (repeat0) ] ; -M: repeat0-parser compile ( parser -- quot ) +M: repeat0-parser (compile) ( parser -- quot ) [ [ V{ } clone ] % - repeat0-parser-p1 compile \ ?quot repeat0-pattern match-replace % + repeat0-parser-p1 compiled-parser \ ?quot repeat0-pattern match-replace % ] [ ] make ; TUPLE: repeat1-parser p1 ; : repeat1-pattern ( -- quot ) [ - ?quot swap (repeat0) [ + [ ?quot ] swap (repeat0) [ dup parse-result-ast empty? [ drop f ] when @@ -156,49 +182,49 @@ TUPLE: repeat1-parser p1 ; ] if* ] ; -M: repeat1-parser compile ( parser -- quot ) +M: repeat1-parser (compile) ( parser -- quot ) [ [ V{ } clone ] % - repeat1-parser-p1 compile \ ?quot repeat1-pattern match-replace % + repeat1-parser-p1 compiled-parser \ ?quot repeat1-pattern match-replace % ] [ ] make ; TUPLE: optional-parser p1 ; : optional-pattern ( -- quot ) [ - dup ?quot call swap f or + dup ?quot swap f or ] ; -M: optional-parser compile ( parser -- quot ) - optional-parser-p1 compile \ ?quot optional-pattern match-replace ; +M: optional-parser (compile) ( parser -- quot ) + optional-parser-p1 compiled-parser \ ?quot optional-pattern match-replace ; TUPLE: ensure-parser p1 ; : ensure-pattern ( -- quot ) [ - dup ?quot call [ + dup ?quot [ ignore ] [ drop f ] if ] ; -M: ensure-parser compile ( parser -- quot ) - ensure-parser-p1 compile \ ?quot ensure-pattern match-replace ; +M: ensure-parser (compile) ( parser -- quot ) + ensure-parser-p1 compiled-parser \ ?quot ensure-pattern match-replace ; TUPLE: ensure-not-parser p1 ; : ensure-not-pattern ( -- quot ) [ - dup ?quot call [ + dup ?quot [ drop f ] [ ignore ] 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 ) + ensure-not-parser-p1 compiled-parser \ ?quot ensure-not-pattern match-replace ; TUPLE: action-parser p1 quot ; @@ -206,14 +232,14 @@ MATCH-VARS: ?action ; : action-pattern ( -- quot ) [ - ?quot call dup [ + ?quot dup [ dup parse-result-ast ?action call swap [ set-parse-result-ast ] keep ] when ] ; -M: action-parser compile ( parser -- quot ) - { action-parser-p1 action-parser-quot } get-slots [ compile ] dip +M: action-parser (compile) ( parser -- quot ) + { action-parser-p1 action-parser-quot } get-slots [ compiled-parser ] dip 2array { ?quot ?action } action-pattern match-replace ; : left-trim-slice ( string -- string ) @@ -225,31 +251,31 @@ M: action-parser compile ( parser -- quot ) TUPLE: sp-parser p1 ; -M: sp-parser compile ( parser -- quot ) +M: sp-parser (compile) ( parser -- quot ) [ - \ left-trim-slice , sp-parser-p1 compile % + \ left-trim-slice , sp-parser-p1 compiled-parser , ] [ ] make ; TUPLE: delay-parser quot ; -M: delay-parser compile ( parser -- quot ) +M: delay-parser (compile) ( parser -- quot ) [ - delay-parser-quot % \ compile , \ call , + delay-parser-quot % \ (compile) , \ call , ] [ ] make ; PRIVATE> : token ( string -- parser ) - token-parser construct-boa ; + token-parser construct-boa init-parser ; : satisfy ( quot -- parser ) - satisfy-parser construct-boa ; + satisfy-parser construct-boa init-parser ; : range ( min max -- parser ) - range-parser construct-boa ; + range-parser construct-boa init-parser ; : seq ( seq -- parser ) - seq-parser construct-boa ; + seq-parser construct-boa init-parser ; : 2seq ( parser1 parser2 -- parser ) 2array seq ; @@ -264,7 +290,7 @@ PRIVATE> { } make seq ; inline : choice ( seq -- parser ) - choice-parser construct-boa ; + choice-parser construct-boa init-parser ; : 2choice ( parser1 parser2 -- parser ) 2array choice ; @@ -279,31 +305,31 @@ PRIVATE> { } make choice ; inline : repeat0 ( parser -- parser ) - repeat0-parser construct-boa ; + repeat0-parser construct-boa init-parser ; : repeat1 ( parser -- parser ) - repeat1-parser construct-boa ; + repeat1-parser construct-boa init-parser ; : optional ( parser -- parser ) - optional-parser construct-boa ; + optional-parser construct-boa init-parser ; : ensure ( parser -- parser ) - ensure-parser construct-boa ; + ensure-parser construct-boa init-parser ; : ensure-not ( parser -- parser ) - ensure-not-parser construct-boa ; + ensure-not-parser construct-boa init-parser ; : action ( parser quot -- parser ) - action-parser construct-boa ; + action-parser construct-boa init-parser ; : sp ( parser -- parser ) - sp-parser construct-boa ; + sp-parser construct-boa init-parser ; : hide ( parser -- parser ) [ drop ignore ] action ; : delay ( quot -- parser ) - delay-parser construct-boa ; + delay-parser construct-boa init-parser ; : PEG: (:) [ From e20762e0cbab95f087061aac7fe275812dd4d94f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 14:25:08 -0500 Subject: [PATCH 117/886] Fix errors --- core/debugger/debugger.factor | 6 +++++- extra/io/encodings/utf16/utf16.factor | 4 ++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index ad2fa14954..cfb696e724 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -6,7 +6,7 @@ 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 ; +kernel.private libc io.encodings ; IN: debugger GENERIC: error. ( error -- ) @@ -282,6 +282,10 @@ M: thread error-in-thread ( error thread -- ) ] bind ] if ; +M: encode-error summary drop "Character encoding error" ; + +M: decode-error summary drop "Character decoding error" ; + r 2 shift r> BIN: 11 bitand bitor - over stream-read1 prepend-nums HEX: 10000 + + over stream-read1 swap append-nums HEX: 10000 + ] [ 2drop dup stream-read1 drop replacement-char ] if ] when* ; From c5eae019300e7339d9acd82db2526cee50b451fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 14:25:23 -0500 Subject: [PATCH 118/886] Small cleanup --- extra/smtp/smtp.factor | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index e15a90eda9..58eb42305e 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -8,7 +8,7 @@ calendar.format new-slots accessors ; IN: smtp SYMBOL: smtp-domain -SYMBOL: smtp-server "localhost" 25 smtp-server set-global +SYMBOL: smtp-server "localhost" "smtp" smtp-server set-global SYMBOL: read-timeout 1 minutes read-timeout set-global SYMBOL: esmtp t esmtp set-global @@ -25,8 +25,10 @@ LOG: log-smtp-connection NOTICE ( addrspec -- ) : 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. @@ -34,13 +36,13 @@ LOG: log-smtp-connection NOTICE ( addrspec -- ) [ "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 ; @@ -49,10 +51,10 @@ LOG: log-smtp-connection NOTICE ( addrspec -- ) string-lines validate-message [ write crlf ] each - "." write crlf ; + "." command ; : quit ( -- ) - "QUIT" write crlf ; + "QUIT" command ; LOG: smtp-response DEBUG @@ -85,7 +87,7 @@ LOG: smtp-response DEBUG 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? From d517bad9ca5bb2e73471f729cdd62843b32e0846 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 14:25:39 -0500 Subject: [PATCH 119/886] Fix race --- extra/tools/vocabs/vocabs.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index d7e1070666..44a64cc9dd 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -108,6 +108,7 @@ MEMO: (vocab-file-contents) ( path -- lines ) : set-vocab-file-contents ( seq vocab name -- ) dupd vocab-append-path [ ?resource-path utf8 set-file-lines + \ (vocab-file-contents) reset-memoized ] [ "The " swap vocab-name " vocabulary was not loaded from the file system" From 02727576c2eeb046f1fc6118767d5a21281cf1ca Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Mar 2008 15:30:59 -0500 Subject: [PATCH 120/886] New slots are now in the core --- core/alien/structs/structs-docs.factor | 61 +++++++- core/alien/structs/structs.factor | 2 +- core/bootstrap/primitives.factor | 9 +- core/slots/deprecated/deprecated.factor | 95 ++++++++++++ core/slots/slots-docs.factor | 61 ++------ core/slots/slots.factor | 146 +++++++----------- core/tuples/tuples.factor | 6 +- core/vocabs/vocabs.factor | 3 +- extra/cairo/lib/lib.factor | 2 +- extra/cairo/png/png.factor | 2 +- extra/calendar/calendar.factor | 2 +- .../distributed/distributed.factor | 2 +- extra/db/db.factor | 2 +- extra/db/postgresql/lib/lib.factor | 2 +- extra/digraphs/digraphs.factor | 2 +- extra/help/help.factor | 4 - extra/help/markup/markup.factor | 57 ------- extra/http/http.factor | 2 +- extra/http/server/actions/actions.factor | 2 +- extra/http/server/auth/basic/basic.factor | 2 +- extra/http/server/auth/login/login.factor | 2 +- .../server/auth/providers/assoc/assoc.factor | 2 +- extra/http/server/auth/providers/db/db.factor | 2 +- .../server/auth/providers/providers.factor | 2 +- extra/http/server/callbacks/callbacks.factor | 2 +- .../server/components/components-tests.factor | 2 +- .../http/server/components/components.factor | 2 +- extra/http/server/db/db.factor | 2 +- extra/http/server/server-tests.factor | 2 +- extra/http/server/server.factor | 2 +- extra/http/server/sessions/sessions.factor | 2 +- .../sessions/storage/assoc/assoc.factor | 2 +- .../http/server/sessions/storage/db/db.factor | 2 +- extra/http/server/static/static.factor | 2 +- .../http/server/validators/validators.factor | 2 +- extra/io/launcher/launcher.factor | 2 +- extra/io/paths/paths.factor | 2 +- extra/io/unix/launcher/launcher.factor | 2 +- extra/io/windows/launcher/launcher.factor | 2 +- extra/io/windows/nt/pipes/pipes.factor | 2 +- extra/locals/locals.factor | 2 +- .../blum-blum-shub/blum-blum-shub.factor | 2 +- extra/random/dummy/dummy.factor | 2 +- .../mersenne-twister/mersenne-twister.factor | 2 +- extra/semantic-db/hierarchy/hierarchy.factor | 2 +- extra/semantic-db/semantic-db.factor | 2 +- extra/serialize/serialize.factor | 2 +- extra/smtp/smtp.factor | 2 +- extra/windows/com/syntax/syntax.factor | 2 +- 49 files changed, 275 insertions(+), 247 deletions(-) create mode 100755 core/slots/deprecated/deprecated.factor mode change 100644 => 100755 core/slots/slots-docs.factor mode change 100644 => 100755 extra/cairo/lib/lib.factor mode change 100644 => 100755 extra/cairo/png/png.factor mode change 100644 => 100755 extra/digraphs/digraphs.factor mode change 100644 => 100755 extra/random/blum-blum-shub/blum-blum-shub.factor mode change 100644 => 100755 extra/random/dummy/dummy.factor mode change 100644 => 100755 extra/semantic-db/hierarchy/hierarchy.factor mode change 100644 => 100755 extra/semantic-db/semantic-db.factor mode change 100644 => 100755 extra/windows/com/syntax/syntax.factor diff --git a/core/alien/structs/structs-docs.factor b/core/alien/structs/structs-docs.factor index fe19f29766..6c7775de2b 100755 --- a/core/alien/structs/structs-docs.factor +++ b/core/alien/structs/structs-docs.factor @@ -1,6 +1,65 @@ 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 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 ; M: string slot-specs c-type struct-type-fields ; diff --git a/core/alien/structs/structs.factor b/core/alien/structs/structs.factor index aec09621cb..e5de8ab83e 100755 --- a/core/alien/structs/structs.factor +++ b/core/alien/structs/structs.factor @@ -2,7 +2,7 @@ ! 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 ) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 354ea672eb..825ee05584 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -1,12 +1,12 @@ ! 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 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 ; +IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush @@ -32,6 +32,9 @@ H{ } clone dictionary set H{ } clone changed-words set H{ } clone root-cache set +! 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. [ drop { } ] recompile-hook set diff --git a/core/slots/deprecated/deprecated.factor b/core/slots/deprecated/deprecated.factor new file mode 100755 index 0000000000..cc93aeeff2 --- /dev/null +++ b/core/slots/deprecated/deprecated.factor @@ -0,0 +1,95 @@ +! Copyright (C) 2005, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel kernel.private math namespaces +sequences strings words effects generic generic.standard +classes slots.private combinators slots ; +IN: slots.deprecated + +: reader-effect ( class spec -- effect ) + >r ?word-name 1array r> slot-spec-name 1array ; + +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 ; + +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 + 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 ; + +: 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 ; diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor old mode 100644 new mode 100755 index d57c4053e6..8a1fb16fa9 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -12,15 +12,11 @@ $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 reader-word } +{ $subsection writer-word } +{ $subsection setter-word } +{ $subsection changer-word } +"Slot methods type check, then call unsafe primitives:" { $subsection slot } { $subsection set-slot } ; @@ -59,17 +55,7 @@ $low-level-note ; 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 } } @@ -80,32 +66,21 @@ 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 } } { $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 +HELP: define-slot-methods { $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" } "." } $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" } "." } @@ -116,18 +91,6 @@ HELP: set-slot ( value obj n -- ) { $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." } ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 7e9046573f..025cf97420 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -16,9 +16,6 @@ C: slot-spec : 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 ; - : reader-quot ( decl -- quot ) [ \ slot , @@ -26,91 +23,62 @@ C: slot-spec [ 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 ; - -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 - 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 ; - -: 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 ) [ slot-spec-name = ] with find nip ; + +: 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" } { "value" } } ; 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 ; diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index e48a803659..d2d3d01c37 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -3,7 +3,8 @@ 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 ; +classes classes.private slots slots.deprecated slots.private +compiler.units ; IN: tuples M: tuple delegate 3 slot ; @@ -85,7 +86,8 @@ PRIVATE> 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 ; + 2dup define-slots + define-accessors ; TUPLE: check-tuple class ; diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 807e08f73b..cf7018b652 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -7,8 +7,7 @@ IN: vocabs SYMBOL: dictionary TUPLE: vocab -name root -words +name words main help source-loaded? docs-loaded? ; diff --git a/extra/cairo/lib/lib.factor b/extra/cairo/lib/lib.factor old mode 100644 new mode 100755 index 9e226ee47a..1b969978a3 --- a/extra/cairo/lib/lib.factor +++ b/extra/cairo/lib/lib.factor @@ -1,7 +1,7 @@ ! 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 +kernel libc locals math combinators.cleave shuffle accessors ; IN: cairo.lib diff --git a/extra/cairo/png/png.factor b/extra/cairo/png/png.factor old mode 100644 new mode 100755 index b9da14088c..55828cde9c --- a/extra/cairo/png/png.factor +++ b/extra/cairo/png/png.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators.cleave kernel new-slots +USING: arrays combinators.cleave kernel accessors math ui.gadgets ui.render opengl.gl byte-arrays namespaces opengl cairo.ffi cairo.lib ; IN: cairo.png diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 7347363e5b..06425975d4 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -3,7 +3,7 @@ USING: arrays kernel math math.functions namespaces sequences strings tuples system vocabs.loader calendar.backend threads -new-slots accessors combinators locals ; +accessors combinators locals ; IN: calendar TUPLE: timestamp year month day hour minute second gmt-offset ; diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index c0787a96a2..c007e9f152 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -3,7 +3,7 @@ USING: serialize sequences concurrency.messaging threads io io.server qualified arrays namespaces kernel io.encodings.binary combinators.cleave -new-slots accessors ; +accessors ; QUALIFIED: io.sockets IN: concurrency.distributed diff --git a/extra/db/db.factor b/extra/db/db.factor index ac46be4422..f9e946fc20 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -2,7 +2,7 @@ ! 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 ; +tools.walker accessors ; IN: db TUPLE: db diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index 928b51dc59..270be886c5 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -4,7 +4,7 @@ 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 +byte-arrays destructors prettyprint accessors strings serialize io.encodings.binary io.streams.byte-array ; IN: db.postgresql.lib diff --git a/extra/digraphs/digraphs.factor b/extra/digraphs/digraphs.factor old mode 100644 new mode 100755 index 5c6fa9b2a1..1776c916ad --- a/extra/digraphs/digraphs.factor +++ b/extra/digraphs/digraphs.factor @@ -1,6 +1,6 @@ ! 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 ; diff --git a/extra/help/help.factor b/extra/help/help.factor index 4cb8cfe854..9e4d02802b 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -25,10 +25,6 @@ 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 ) diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 47a40d6948..9c3615f629 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -296,63 +296,6 @@ M: string ($instance) { $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 ; diff --git a/extra/http/http.factor b/extra/http/http.factor index 421a409639..0bb983c53d 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -3,7 +3,7 @@ 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 +combinators vectors sorting accessors calendar calendar.format quotations arrays combinators.cleave combinators.lib byte-arrays ; IN: http diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index 287f6dd907..f39980037d 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors new-slots sequences kernel assocs combinators +USING: accessors sequences kernel assocs combinators http.server http.server.validators http hashtables namespaces combinators.cleave fry continuations locals ; IN: http.server.actions diff --git a/extra/http/server/auth/basic/basic.factor b/extra/http/server/auth/basic/basic.factor index 2ea74febba..04c0e62d07 100755 --- a/extra/http/server/auth/basic/basic.factor +++ b/extra/http/server/auth/basic/basic.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors new-slots quotations assocs kernel splitting +USING: accessors quotations assocs kernel splitting base64 html.elements io combinators http.server http.server.auth.providers http.server.auth.providers.null http sequences ; diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 275fb0ff63..8c61a9dd47 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors new-slots quotations assocs kernel splitting +USING: accessors quotations assocs kernel splitting base64 html.elements io combinators http.server http.server.auth.providers http.server.auth.providers.null http.server.actions http.server.components http.server.sessions diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor index e8ab908406..18ec8da62a 100755 --- a/extra/http/server/auth/providers/assoc/assoc.factor +++ b/extra/http/server/auth/providers/assoc/assoc.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: http.server.auth.providers.assoc -USING: new-slots accessors assocs kernel +USING: accessors assocs kernel http.server.auth.providers ; TUPLE: users-in-memory assoc ; diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor index aec64d3384..1e84e544b8 100755 --- a/extra/http/server/auth/providers/db/db.factor +++ b/extra/http/server/auth/providers/db/db.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: db db.tuples db.types new-slots accessors +USING: db db.tuples db.types accessors http.server.auth.providers kernel continuations singleton ; IN: http.server.auth.providers.db diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor index cdad4815a6..eda3babf0f 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/http/server/auth/providers/providers.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel new-slots accessors random math.parser locals +USING: kernel accessors random math.parser locals sequences math crypto.sha2 ; IN: http.server.auth.providers diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor index eb264279cb..ab629ae236 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/http/server/callbacks/callbacks.factor @@ -2,7 +2,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: html http http.server io kernel math namespaces -continuations calendar sequences assocs new-slots hashtables +continuations calendar sequences assocs hashtables accessors arrays alarms quotations combinators combinators.cleave fry assocs.lib ; IN: http.server.callbacks diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor index 09d31202c5..d372865b7e 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -1,6 +1,6 @@ IN: http.server.components.tests USING: http.server.components http.server.validators -namespaces tools.test kernel accessors new-slots +namespaces tools.test kernel accessors tuple-syntax mirrors http.server.actions ; validation-failed? off diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 8581335f3d..516abe79a5 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: new-slots html.elements http.server.validators accessors +USING: 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 diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor index 4a2315b4fd..0b2e9bccc3 100755 --- a/extra/http/server/db/db.factor +++ b/extra/http/server/db/db.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: db http.server kernel new-slots accessors +USING: db http.server kernel accessors continuations namespaces destructors combinators.cleave ; IN: http.server.db diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index e992a1b6fa..346a31f30f 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,5 +1,5 @@ USING: http.server tools.test kernel namespaces accessors -new-slots io http math sequences assocs ; +io http math sequences assocs ; IN: http.server.tests [ diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 7448752c60..6b3ae52730 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,7 +2,7 @@ ! 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 ; IN: http.server diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index f45f10d25f..aea1bef930 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -1,7 +1,7 @@ ! 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 ; diff --git a/extra/http/server/sessions/storage/assoc/assoc.factor b/extra/http/server/sessions/storage/assoc/assoc.factor index 1339e3c867..f72f34e4d2 100755 --- a/extra/http/server/sessions/storage/assoc/assoc.factor +++ b/extra/http/server/sessions/storage/assoc/assoc.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs assocs.lib new-slots accessors +USING: assocs assocs.lib accessors http.server.sessions.storage combinators.cleave alarms kernel fry http.server ; IN: http.server.sessions.storage.assoc diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor index 07cd22bc62..4d87aea5a3 100755 --- a/extra/http/server/sessions/storage/db/db.factor +++ b/extra/http/server/sessions/storage/db/db.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs new-slots accessors http.server.sessions.storage +USING: assocs accessors http.server.sessions.storage alarms kernel http.server db.tuples db.types singleton combinators.cleave math.parser ; IN: http.server.sessions.storage.db diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index b001242776..37c3a63d76 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -3,7 +3,7 @@ USING: calendar html io io.files kernel math math.parser http http.server namespaces parser sequences strings assocs hashtables debugger http.mime sorting html.elements logging -calendar.format new-slots accessors io.encodings.binary +calendar.format accessors io.encodings.binary combinators.cleave fry ; IN: http.server.static diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor index f2d1f568e6..b3710f6439 100755 --- a/extra/http/server/validators/validators.factor +++ b/extra/http/server/validators/validators.factor @@ -1,7 +1,7 @@ ! 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 +math.parser assocs regexp fry unicode.categories combinators.cleave sequences ; IN: http.server.validators diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index e133416101..9c7d64934e 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -3,7 +3,7 @@ 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 ; IN: io.launcher diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index 163194195d..6c73669e9f 100755 --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -1,4 +1,4 @@ -USING: io.files kernel sequences new-slots accessors +USING: io.files kernel sequences accessors dlists arrays sequences.lib ; IN: io.paths diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 7b4831a2c5..a1e42fddf2 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.nonblocking io.unix.backend 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 io.encodings.latin1 accessors ; IN: io.unix.launcher ! Search unix first diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 3e49f1dc10..ca8f5f3e59 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -5,7 +5,7 @@ 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 splitting system threads init strings combinators -io.backend new-slots accessors concurrency.flags ; +io.backend accessors concurrency.flags ; IN: io.windows.launcher TUPLE: CreateProcess-args diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor index 6fd38e74b2..f2aca0470d 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -3,7 +3,7 @@ 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 diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index cc1785ff62..640ae0c9ea 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -5,7 +5,7 @@ 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 new-slots accessors ; +compiler.units combinators.cleave accessors ; IN: locals ! Inspired by diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor old mode 100644 new mode 100755 index e1ba48281a..2e59b625b1 --- a/extra/random/blum-blum-shub/blum-blum-shub.factor +++ b/extra/random/blum-blum-shub/blum-blum-shub.factor @@ -1,6 +1,6 @@ USING: kernel math sequences namespaces math.miller-rabin combinators.cleave combinators.lib -math.functions new-slots accessors random ; +math.functions accessors random ; IN: random.blum-blum-shub ! TODO: take (log log M) bits instead of 1 bit diff --git a/extra/random/dummy/dummy.factor b/extra/random/dummy/dummy.factor old mode 100644 new mode 100755 index af6e2365bb..12607456ec --- a/extra/random/dummy/dummy.factor +++ b/extra/random/dummy/dummy.factor @@ -1,4 +1,4 @@ -USING: kernel random math new-slots accessors ; +USING: kernel random math accessors ; IN: random.dummy TUPLE: random-dummy i ; diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index 73f241a370..bf2ff78f2d 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -4,7 +4,7 @@ ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c USING: arrays kernel math namespaces sequences system init -new-slots accessors math.ranges combinators.cleave random ; +accessors math.ranges combinators.cleave random ; IN: random.mersenne-twister Date: Thu, 20 Mar 2008 18:02:19 -0500 Subject: [PATCH 121/886] finally fix openbsd stat --- extra/unix/stat/openbsd/openbsd.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/unix/stat/openbsd/openbsd.factor b/extra/unix/stat/openbsd/openbsd.factor index 38ebf66abc..decfb0dbb1 100644 --- a/extra/unix/stat/openbsd/openbsd.factor +++ b/extra/unix/stat/openbsd/openbsd.factor @@ -22,8 +22,7 @@ C-STRUCT: stat { "u_int32_t" "st_gen" } { "int32_t" "st_lspare1" } { "timespec" "st_birthtim" } - { "int64_t" "st_qspare1" } - { "int64_t" "st_qspare2" } ; + { { "int64_t" 2 } "st_qspare" } ; FUNCTION: int stat ( char* pathname, stat* buf ) ; FUNCTION: int lstat ( char* pathname, stat* buf ) ; From d1e72fd03b8cf8bcf57c2e077b6dc967e7f45548 Mon Sep 17 00:00:00 2001 From: sheeple Date: Thu, 20 Mar 2008 23:53:05 -0500 Subject: [PATCH 122/886] make freebsd64 compile --- vm/os-freebsd-x86.64.h | 9 +++++++++ vm/platform.h | 2 ++ 2 files changed, 11 insertions(+) create mode 100644 vm/os-freebsd-x86.64.h diff --git a/vm/os-freebsd-x86.64.h b/vm/os-freebsd-x86.64.h new file mode 100644 index 0000000000..23e1ff5733 --- /dev/null +++ b/vm/os-freebsd-x86.64.h @@ -0,0 +1,9 @@ +#include + +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) diff --git a/vm/platform.h b/vm/platform.h index 66f22bbf96..cd2b6e0a0e 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -49,6 +49,8 @@ #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 From 2bdfc463318785384676c613d19a5635ff56788f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 21 Mar 2008 00:31:00 -0500 Subject: [PATCH 123/886] Move bitmaps --- extra/graphics/bitmap/bitmap.factor | 8 ++++---- .../graphics/bitmap/test-images}/1bit.bmp | Bin .../graphics/bitmap/test-images}/rgb4bit.bmp | Bin .../graphics/bitmap/test-images}/rgb8bit.bmp | Bin .../graphics/bitmap/test-images}/thiswayup24.bmp | Bin 5 files changed, 4 insertions(+), 4 deletions(-) mode change 100644 => 100755 extra/graphics/bitmap/bitmap.factor rename {misc/graphics/bmps => extra/graphics/bitmap/test-images}/1bit.bmp (100%) rename {misc/graphics/bmps => extra/graphics/bitmap/test-images}/rgb4bit.bmp (100%) rename {misc/graphics/bmps => extra/graphics/bitmap/test-images}/rgb8bit.bmp (100%) rename {misc/graphics/bmps => extra/graphics/bitmap/test-images}/thiswayup24.bmp (100%) diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor old mode 100644 new mode 100755 index ec4d6b79e1..861894c8f4 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -117,16 +117,16 @@ M: bitmap height ( bitmap -- ) bitmap-height ; load-bitmap [ "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. ; diff --git a/misc/graphics/bmps/1bit.bmp b/extra/graphics/bitmap/test-images/1bit.bmp similarity index 100% rename from misc/graphics/bmps/1bit.bmp rename to extra/graphics/bitmap/test-images/1bit.bmp diff --git a/misc/graphics/bmps/rgb4bit.bmp b/extra/graphics/bitmap/test-images/rgb4bit.bmp similarity index 100% rename from misc/graphics/bmps/rgb4bit.bmp rename to extra/graphics/bitmap/test-images/rgb4bit.bmp diff --git a/misc/graphics/bmps/rgb8bit.bmp b/extra/graphics/bitmap/test-images/rgb8bit.bmp similarity index 100% rename from misc/graphics/bmps/rgb8bit.bmp rename to extra/graphics/bitmap/test-images/rgb8bit.bmp diff --git a/misc/graphics/bmps/thiswayup24.bmp b/extra/graphics/bitmap/test-images/thiswayup24.bmp similarity index 100% rename from misc/graphics/bmps/thiswayup24.bmp rename to extra/graphics/bitmap/test-images/thiswayup24.bmp From 15a747cce4fa195a73a1c028470aaa9dbec470f8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 21 Mar 2008 00:37:27 -0500 Subject: [PATCH 124/886] Move things around a bit --- Makefile | 8 ++++---- {misc => build-support}/target | 0 {misc => build-support}/wordsize.c | 0 3 files changed, 4 insertions(+), 4 deletions(-) rename {misc => build-support}/target (100%) rename {misc => build-support}/wordsize.c (100%) diff --git a/Makefile b/Makefile index 054d57b641..ecb333a0b2 100755 --- a/Makefile +++ b/Makefile @@ -45,8 +45,8 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ EXE_OBJS = $(PLAF_EXE_OBJS) -default: misc/wordsize - $(MAKE) `./misc/target` +default: build-support/wordsize + $(MAKE) `./build-support/target` help: @echo "Run '$(MAKE)' with one of the following parameters:" @@ -162,8 +162,8 @@ factor: $(DLL_OBJS) $(EXE_OBJS) $(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 +build-support/wordsize: build-support/wordsize.c + gcc build-support/wordsize.c -o build-support/wordsize clean: rm -f vm/*.o diff --git a/misc/target b/build-support/target similarity index 100% rename from misc/target rename to build-support/target diff --git a/misc/wordsize.c b/build-support/wordsize.c similarity index 100% rename from misc/wordsize.c rename to build-support/wordsize.c From b84055515737e22e45a4cd9d8edad487a0d4d699 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 21 Mar 2008 00:37:58 -0500 Subject: [PATCH 125/886] Clean things up for binary releases --- {misc => build-support}/grovel.c | 0 core/io/files/files-tests.factor | 2 +- misc/version.sh | 1 - 3 files changed, 1 insertion(+), 2 deletions(-) rename {misc => build-support}/grovel.c (100%) delete mode 100644 misc/version.sh diff --git a/misc/grovel.c b/build-support/grovel.c similarity index 100% rename from misc/grovel.c rename to build-support/grovel.c diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 739b55882d..4cda463983 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -131,7 +131,7 @@ io.files.unique sequences strings accessors ; [ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test -[ ] [ "append-test" ascii dispose ] unit-test +[ ] [ "append-test" temp-file ascii dispose ] unit-test diff --git a/misc/version.sh b/misc/version.sh deleted file mode 100644 index 9c5d02d463..0000000000 --- a/misc/version.sh +++ /dev/null @@ -1 +0,0 @@ -export VERSION=0.92 From 95e960c6eccd6b0b8cefe4e1eab6643e62bacd9b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 21 Mar 2008 00:39:28 -0500 Subject: [PATCH 126/886] Fix target script --- build-support/target | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/build-support/target b/build-support/target index c9f927a507..239862c3ae 100755 --- a/build-support/target +++ b/build-support/target @@ -17,7 +17,7 @@ then echo macosx-ppc elif [ `uname -s` = Darwin ] then - echo macosx-x86-`./misc/wordsize` + echo macosx-x86-`./build-support/wordsize` elif [ \( `uname -s` = Linux \) -a \( `uname -m` = i686 \) ] then echo linux-x86-32 @@ -26,7 +26,7 @@ then echo linux-x86-64 elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ] then - echo winnt-x86-`./misc/wordsize` + echo winnt-x86-`./build-support/wordsize` else echo help fi From 7c83016eee55c4bb381f682c375d440fe23eaadd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 21 Mar 2008 00:40:02 -0500 Subject: [PATCH 127/886] Update .gitignore --- .gitignore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 19ace1f500..7e1e52d866 100644 --- a/.gitignore +++ b/.gitignore @@ -18,4 +18,4 @@ factor temp logs work -misc/wordsize \ No newline at end of file +buildsupport/wordsize From 2da79d04fdb43dfda90ecadc1ac0e655203fc949 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 19:11:01 -0500 Subject: [PATCH 128/886] add some constants to grovel --- build-support/grovel.c | 37 +++++++++++++++++++++++++++++++++---- 1 file changed, 33 insertions(+), 4 deletions(-) diff --git a/build-support/grovel.c b/build-support/grovel.c index 2e39d2495e..2b8aad2e5f 100644 --- a/build-support/grovel.c +++ b/build-support/grovel.c @@ -32,9 +32,12 @@ #if defined(UNIX) #include #include + #include + #include + #include + #include #endif - #define BL printf(" "); #define QUOT printf("\""); #define NL printf("\n"); @@ -50,6 +53,7 @@ #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() { @@ -79,9 +83,9 @@ void openbsd_stat() grovel2(gid_t, "st_gid"); grovel2(dev_t, "st_rdev"); grovel2(int32_t, "st_lspare0"); - grovel2(struct timespec, "st_atimespec"); - grovel2(struct timespec, "st_mtimespec"); - grovel2(struct timespec, "st_ctimespec"); + 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"); @@ -109,6 +113,28 @@ void unix_types() 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); +} int main() { //grovel(char); @@ -121,6 +147,7 @@ int main() { //grovel(void*); //grovel(char*); + #ifdef FREEBSD grovel(blkcnt_t); grovel(blksize_t); @@ -134,8 +161,10 @@ int main() { #ifdef UNIX unix_types(); + unix_constants(); #endif grovel(long); return 0; } + From 327c07b67e82ad187989e552db1c0d457e948fea Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 19:11:04 -0500 Subject: [PATCH 129/886] make md5 work on netbsd in factor.sh --- misc/factor.sh | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/misc/factor.sh b/misc/factor.sh index b96aa8d24b..276956b0b7 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -306,7 +306,10 @@ update_boot_images() { 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' '`; + 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 From 36d02462ce41218c1e9dab42e754dd6ef741f89c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 19:12:06 -0500 Subject: [PATCH 130/886] add netbsd to targets add stat/types for netbsd fix type for openbsd --- build-support/target | 6 +++++ extra/unix/stat/netbsd/netbsd.factor | 26 ++++++++++++++++++++ extra/unix/types/netbsd/netbsd.factor | 32 +++++++++++++++++++++++++ extra/unix/types/openbsd/openbsd.factor | 3 ++- 4 files changed, 66 insertions(+), 1 deletion(-) create mode 100644 extra/unix/stat/netbsd/netbsd.factor create mode 100755 extra/unix/types/netbsd/netbsd.factor diff --git a/build-support/target b/build-support/target index 239862c3ae..8e07c1afdc 100755 --- a/build-support/target +++ b/build-support/target @@ -12,6 +12,12 @@ then elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = amd64 \) ] then echo openbsd-x86-64 +elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = i386 \) ] +then + echo netbsd-x86-32 +elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = amd64 \) ] +then + echo netbsd-x86-64 elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ] then echo macosx-ppc diff --git a/extra/unix/stat/netbsd/netbsd.factor b/extra/unix/stat/netbsd/netbsd.factor new file mode 100644 index 0000000000..bb2df6d6d3 --- /dev/null +++ b/extra/unix/stat/netbsd/netbsd.factor @@ -0,0 +1,26 @@ +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 stat ( char* pathname, stat* buf ) ; +FUNCTION: int lstat ( char* pathname, stat* buf ) ; diff --git a/extra/unix/types/netbsd/netbsd.factor b/extra/unix/types/netbsd/netbsd.factor new file mode 100755 index 0000000000..d65bcb3d33 --- /dev/null +++ b/extra/unix/types/netbsd/netbsd.factor @@ -0,0 +1,32 @@ +USING: alien.syntax ; +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 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 diff --git a/extra/unix/types/openbsd/openbsd.factor b/extra/unix/types/openbsd/openbsd.factor index 7445dada2b..5bdda212d8 100755 --- a/extra/unix/types/openbsd/openbsd.factor +++ b/extra/unix/types/openbsd/openbsd.factor @@ -11,7 +11,8 @@ TYPEDEF: longlong __int64_t TYPEDEF: longlong __uint64_t TYPEDEF: int int32_t -TYPEDEF: int u_int32_t +TYPEDEF: uint u_int32_t +TYPEDEF: uint uint32_t TYPEDEF: longlong int64_t TYPEDEF: ulonglong u_int64_t From 9402b9b11ed82e5499c20bb58ee7d3eb0c7e77c0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Mar 2008 19:15:16 -0500 Subject: [PATCH 131/886] fix stat on netbsd --- extra/unix/types/netbsd/netbsd.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/unix/types/netbsd/netbsd.factor b/extra/unix/types/netbsd/netbsd.factor index d65bcb3d33..77636a6d6d 100755 --- a/extra/unix/types/netbsd/netbsd.factor +++ b/extra/unix/types/netbsd/netbsd.factor @@ -18,7 +18,7 @@ TYPEDEF: ulonglong u_int64_t TYPEDEF: __uint32_t __dev_t TYPEDEF: __uint32_t dev_t -TYPEDEF: __uint32_t ino_t +TYPEDEF: __uint64_t ino_t TYPEDEF: __uint32_t mode_t TYPEDEF: __uint32_t nlink_t TYPEDEF: __uint32_t uid_t From 4e2c5f2d5998123b178d39dcd06e29893454e7be Mon Sep 17 00:00:00 2001 From: sheeple Date: Thu, 20 Mar 2008 19:55:46 -0500 Subject: [PATCH 132/886] delete comments --- build-support/grovel.c | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/build-support/grovel.c b/build-support/grovel.c index 2b8aad2e5f..600865cf39 100644 --- a/build-support/grovel.c +++ b/build-support/grovel.c @@ -137,17 +137,6 @@ void unix_constants() } int main() { - //grovel(char); - //grovel(int); - //grovel(uint); - //grovel(long); - //grovel(ulong); - //grovel(long long); - //grovel(unsigned long long); - //grovel(void*); - //grovel(char*); - - #ifdef FREEBSD grovel(blkcnt_t); grovel(blksize_t); @@ -164,7 +153,5 @@ int main() { unix_constants(); #endif - grovel(long); return 0; } - From d1e0aa6e806e730d1972274e262a2f5b8ddd3563 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 22 Mar 2008 00:58:53 +1300 Subject: [PATCH 133/886] Get peg subvocabs working again --- extra/peg/ebnf/ebnf-tests.factor | 2 +- extra/peg/ebnf/ebnf.factor | 2 +- extra/peg/peg.factor | 8 ++++---- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 54639431a4..c9b9f5d977 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -1,7 +1,7 @@ ! 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 ; IN: peg.ebnf.tests { T{ ebnf-non-terminal f "abc" } } [ diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index ab7baa547e..db478e571f 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -278,7 +278,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) : ebnf>quot ( string -- hashtable quot ) 'ebnf' parse check-parse-result - parse-result-ast transform dup main swap at compile ; + parse-result-ast transform dup main swap at compile 1quotation ; : [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 9d6b18398e..47dc0a3454 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -3,7 +3,7 @@ USING: kernel sequences strings namespaces math assocs shuffle vectors arrays combinators.lib math.parser match unicode.categories sequences.lib compiler.units parser - words ; + words quotations ; IN: peg TUPLE: parse-result remaining ast ; @@ -42,7 +42,7 @@ GENERIC: (compile) ( parser -- quot ) ] with-variable ; : parse ( state parser -- result ) - compile call ; + compile execute ; @@ -334,7 +334,7 @@ PRIVATE> : PEG: (:) [ [ - call compile + call compile 1quotation [ dup [ parse-result-ast ] [ "Parse failed" throw ] if ] append define ] with-compilation-unit From 943b02ab2f1893012ff68af1bef4214f03c4d349 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 22 Mar 2008 01:59:16 +1300 Subject: [PATCH 134/886] Fix performance regression in pegs delay parser is improved to use a memoized quotation so the construction and compilation of the parser at runtime only occurs once. Changed compile so it would use equality rather than identity for memoization purposes. --- extra/peg/parsers/parsers.factor | 2 +- extra/peg/peg.factor | 50 +++++++++++++++----------------- 2 files changed, 25 insertions(+), 27 deletions(-) diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 407729004f..4bba60bb09 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -20,7 +20,7 @@ M: just-parser (compile) ( parser -- quot ) just-parser-p1 compiled-parser just-pattern curry ; : just ( parser -- parser ) - just-parser construct-boa init-parser ; + just-parser construct-boa ; : 1token ( ch -- parser ) 1string token ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 47dc0a3454..1707193e70 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -3,7 +3,7 @@ USING: kernel sequences strings namespaces math assocs shuffle vectors arrays combinators.lib math.parser match unicode.categories sequences.lib compiler.units parser - words quotations ; + words quotations effects memoize ; IN: peg TUPLE: parse-result remaining ast ; @@ -13,20 +13,12 @@ SYMBOL: ignore : ( remaining ast -- parse-result ) parse-result construct-boa ; -TUPLE: parser ; -C: parser -M: parser equal? eq? ; - -: init-parser ( parser -- parser ) - #! Set the delegate for the parser - over set-delegate ; - SYMBOL: compiled-parsers GENERIC: (compile) ( parser -- quot ) : compiled-parser ( parser -- word ) - #! Look to see if the given parser has been compied. + #! 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. dup compiled-parsers get at [ @@ -36,7 +28,7 @@ GENERIC: (compile) ( parser -- quot ) [ swap compiled-parsers get set-at ] keep ] if* ; -: compile ( parser -- word ) +MEMO: compile ( parser -- word ) H{ } clone compiled-parsers [ [ compiled-parser ] with-compilation-unit ] with-variable ; @@ -47,6 +39,7 @@ GENERIC: (compile) ( parser -- quot ) memoize-quot + [ % \ execute , ] [ ] make ; PRIVATE> : token ( string -- parser ) - token-parser construct-boa init-parser ; + token-parser construct-boa ; : satisfy ( quot -- parser ) - satisfy-parser construct-boa init-parser ; + satisfy-parser construct-boa ; : range ( min max -- parser ) - range-parser construct-boa init-parser ; + range-parser construct-boa ; : seq ( seq -- parser ) - seq-parser construct-boa init-parser ; + seq-parser construct-boa ; : 2seq ( parser1 parser2 -- parser ) 2array seq ; @@ -290,7 +288,7 @@ PRIVATE> { } make seq ; inline : choice ( seq -- parser ) - choice-parser construct-boa init-parser ; + choice-parser construct-boa ; : 2choice ( parser1 parser2 -- parser ) 2array choice ; @@ -305,31 +303,31 @@ PRIVATE> { } make choice ; inline : repeat0 ( parser -- parser ) - repeat0-parser construct-boa init-parser ; + repeat0-parser construct-boa ; : repeat1 ( parser -- parser ) - repeat1-parser construct-boa init-parser ; + repeat1-parser construct-boa ; : optional ( parser -- parser ) - optional-parser construct-boa init-parser ; + optional-parser construct-boa ; : ensure ( parser -- parser ) - ensure-parser construct-boa init-parser ; + ensure-parser construct-boa ; : ensure-not ( parser -- parser ) - ensure-not-parser construct-boa init-parser ; + ensure-not-parser construct-boa ; : action ( parser quot -- parser ) - action-parser construct-boa init-parser ; + action-parser construct-boa ; : sp ( parser -- parser ) - sp-parser construct-boa init-parser ; + sp-parser construct-boa ; : hide ( parser -- parser ) [ drop ignore ] action ; : delay ( quot -- parser ) - delay-parser construct-boa init-parser ; + delay-parser construct-boa ; : PEG: (:) [ From 3586b5a35d8b043fb46389064ccd691766c9cb30 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 21 Mar 2008 12:30:13 -0400 Subject: [PATCH 135/886] More 8-bit encodings --- extra/io/encodings/8-bit/8-bit-tests.factor | 9 + extra/io/encodings/8-bit/8-bit.factor | 89 +++++ extra/io/encodings/8-bit/8859-1.TXT | 303 ++++++++++++++ extra/io/encodings/8-bit/8859-10.TXT | 303 ++++++++++++++ extra/io/encodings/8-bit/8859-11.TXT | 297 ++++++++++++++ extra/io/encodings/8-bit/8859-13.TXT | 299 ++++++++++++++ extra/io/encodings/8-bit/8859-14.TXT | 301 ++++++++++++++ extra/io/encodings/8-bit/8859-15.TXT | 303 ++++++++++++++ extra/io/encodings/8-bit/8859-16.TXT | 299 ++++++++++++++ extra/io/encodings/8-bit/8859-2.TXT | 303 ++++++++++++++ extra/io/encodings/8-bit/8859-3.TXT | 296 ++++++++++++++ extra/io/encodings/8-bit/8859-4.TXT | 303 ++++++++++++++ extra/io/encodings/8-bit/8859-5.TXT | 303 ++++++++++++++ extra/io/encodings/8-bit/8859-6.TXT | 260 ++++++++++++ extra/io/encodings/8-bit/8859-7.TXT | 308 +++++++++++++++ extra/io/encodings/8-bit/8859-8.TXT | 270 +++++++++++++ extra/io/encodings/8-bit/8859-9.TXT | 307 +++++++++++++++ extra/io/encodings/8-bit/CP037.TXT | 275 +++++++++++++ extra/io/encodings/8-bit/CP1252.TXT | 274 +++++++++++++ extra/io/encodings/8-bit/GSM0338.TXT | 239 +++++++++++ extra/io/encodings/8-bit/KOI8-R.TXT | 302 ++++++++++++++ extra/io/encodings/8-bit/ROMAN.TXT | 370 ++++++++++++++++++ .../encodings/{latin1 => 8-bit}/authors.txt | 0 extra/io/encodings/8-bit/summary.txt | 1 + extra/io/encodings/{latin1 => 8-bit}/tags.txt | 0 extra/io/encodings/latin1/latin1-docs.factor | 5 - extra/io/encodings/latin1/latin1-tests.factor | 9 - extra/io/encodings/latin1/latin1.factor | 12 - extra/io/encodings/latin1/summary.txt | 1 - 29 files changed, 6014 insertions(+), 27 deletions(-) create mode 100644 extra/io/encodings/8-bit/8-bit-tests.factor create mode 100644 extra/io/encodings/8-bit/8-bit.factor create mode 100644 extra/io/encodings/8-bit/8859-1.TXT create mode 100644 extra/io/encodings/8-bit/8859-10.TXT create mode 100644 extra/io/encodings/8-bit/8859-11.TXT create mode 100644 extra/io/encodings/8-bit/8859-13.TXT create mode 100644 extra/io/encodings/8-bit/8859-14.TXT create mode 100644 extra/io/encodings/8-bit/8859-15.TXT create mode 100644 extra/io/encodings/8-bit/8859-16.TXT create mode 100644 extra/io/encodings/8-bit/8859-2.TXT create mode 100644 extra/io/encodings/8-bit/8859-3.TXT create mode 100644 extra/io/encodings/8-bit/8859-4.TXT create mode 100644 extra/io/encodings/8-bit/8859-5.TXT create mode 100644 extra/io/encodings/8-bit/8859-6.TXT create mode 100644 extra/io/encodings/8-bit/8859-7.TXT create mode 100644 extra/io/encodings/8-bit/8859-8.TXT create mode 100644 extra/io/encodings/8-bit/8859-9.TXT create mode 100644 extra/io/encodings/8-bit/CP037.TXT create mode 100644 extra/io/encodings/8-bit/CP1252.TXT create mode 100644 extra/io/encodings/8-bit/GSM0338.TXT create mode 100644 extra/io/encodings/8-bit/KOI8-R.TXT create mode 100644 extra/io/encodings/8-bit/ROMAN.TXT rename extra/io/encodings/{latin1 => 8-bit}/authors.txt (100%) create mode 100644 extra/io/encodings/8-bit/summary.txt rename extra/io/encodings/{latin1 => 8-bit}/tags.txt (100%) delete mode 100644 extra/io/encodings/latin1/latin1-docs.factor delete mode 100644 extra/io/encodings/latin1/latin1-tests.factor delete mode 100755 extra/io/encodings/latin1/latin1.factor delete mode 100644 extra/io/encodings/latin1/summary.txt diff --git a/extra/io/encodings/8-bit/8-bit-tests.factor b/extra/io/encodings/8-bit/8-bit-tests.factor new file mode 100644 index 0000000000..316e496219 --- /dev/null +++ b/extra/io/encodings/8-bit/8-bit-tests.factor @@ -0,0 +1,9 @@ +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" iso-8859-1 encode ] unit-test +[ { 256 } >string iso-8859-1 encode ] must-fail +[ B{ 255 } ] [ { 255 } iso-8859-1 encode ] unit-test + +[ "bar" ] [ "bar" iso-8859-1 decode ] unit-test +[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } iso-8859-1 decode >array ] unit-test diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor new file mode 100644 index 0000000000..ff0e6ec8bf --- /dev/null +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -0,0 +1,89 @@ +! 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 combinators.cleave +generic parser tuples words io io.files splitting namespaces +classes quotations ; +IN: io.encodings.8-bit + + ] map ] map ; + +: byte>ch ( assoc -- array ) + 256 replacement-char + [ [ swapd set-nth ] curry assoc-each ] keep ; + +: ch>byte ( assoc -- newassoc ) + [ swap ] assoc-map >hashtable ; + +: parse-file ( file-name -- byte>ch ch>byte ) + full-path ascii file-lines process-contents + [ byte>ch ] [ ch>byte ] bi ; + +: empty-tuple-class ( string -- class ) + in get create + dup { f } "slots" set-word-prop + dup predicate-word drop + dup { } define-tuple-class ; + +: data-quot ( class word data -- quot ) + >r [ word-name ] 2apply "/" swap 3append + "/data" append in get create dup 1quotation swap r> + 1quotation define ; + +: method-with-data ( class data word quot -- ) + >r swap >r 2dup r> data-quot r> + compose >r create-method r> define ; + +: encode-8-bit ( char stream encoding assoc -- ) + nip swapd at* [ encode-error ] unless swap stream-write1 ; + +: define-encode-char ( class assoc -- ) + \ encode-char [ encode-8-bit ] method-with-data ; + +: decode-8-bit ( stream encoding array -- char/f ) + nip swap stream-read1 [ swap nth ] [ drop f ] if* ; + +: define-decode-char ( class array -- ) + \ decode-char [ decode-8-bit ] method-with-data ; + +: 8-bit-methods ( class byte>ch ch>byte -- ) + >r over r> define-encode-char define-decode-char ; + +: define-8-bit-encoding ( tuple-name file-name -- ) + >r empty-tuple-class r> parse-file 8-bit-methods ; + +PRIVATE> + +! << mappings [ define-8-bit-encoding ] assoc-each >> diff --git a/extra/io/encodings/8-bit/8859-1.TXT b/extra/io/encodings/8-bit/8859-1.TXT new file mode 100644 index 0000000000..473ecabc17 --- /dev/null +++ b/extra/io/encodings/8-bit/8859-1.TXT @@ -0,0 +1,303 @@ +# +# 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 +# +# 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: +# +# +# Any comments or problems, contact +# Please note that 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 # +0x81 0x0081 # +0x82 0x0082 # +0x83 0x0083 # +0x84 0x0084 # +0x85 0x0085 # +0x86 0x0086 # +0x87 0x0087 # +0x88 0x0088 # +0x89 0x0089 # +0x8A 0x008A # +0x8B 0x008B # +0x8C 0x008C # +0x8D 0x008D # +0x8E 0x008E # +0x8F 0x008F # +0x90 0x0090 # +0x91 0x0091 # +0x92 0x0092 # +0x93 0x0093 # +0x94 0x0094 # +0x95 0x0095 # +0x96 0x0096 # +0x97 0x0097 # +0x98 0x0098 # +0x99 0x0099 # +0x9A 0x009A # +0x9B 0x009B # +0x9C 0x009C # +0x9D 0x009D # +0x9E 0x009E # +0x9F 0x009F # +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 diff --git a/extra/io/encodings/8-bit/8859-10.TXT b/extra/io/encodings/8-bit/8859-10.TXT new file mode 100644 index 0000000000..374a42b1a5 --- /dev/null +++ b/extra/io/encodings/8-bit/8859-10.TXT @@ -0,0 +1,303 @@ +# +# 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 +# +# 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: +# +# +# Any comments or problems, contact +# Please note that 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 # +0x81 0x0081 # +0x82 0x0082 # +0x83 0x0083 # +0x84 0x0084 # +0x85 0x0085 # +0x86 0x0086 # +0x87 0x0087 # +0x88 0x0088 # +0x89 0x0089 # +0x8A 0x008A # +0x8B 0x008B # +0x8C 0x008C # +0x8D 0x008D # +0x8E 0x008E # +0x8F 0x008F # +0x90 0x0090 # +0x91 0x0091 # +0x92 0x0092 # +0x93 0x0093 # +0x94 0x0094 # +0x95 0x0095 # +0x96 0x0096 # +0x97 0x0097 # +0x98 0x0098 # +0x99 0x0099 # +0x9A 0x009A # +0x9B 0x009B # +0x9C 0x009C # +0x9D 0x009D # +0x9E 0x009E # +0x9F 0x009F # +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 diff --git a/extra/io/encodings/8-bit/8859-11.TXT b/extra/io/encodings/8-bit/8859-11.TXT new file mode 100644 index 0000000000..192bd9d7cf --- /dev/null +++ b/extra/io/encodings/8-bit/8859-11.TXT @@ -0,0 +1,297 @@ +# +# 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 +# +# 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: +# +# +# 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 # +0x81 0x0081 # +0x82 0x0082 # +0x83 0x0083 # +0x84 0x0084 # +0x85 0x0085 # +0x86 0x0086 # +0x87 0x0087 # +0x88 0x0088 # +0x89 0x0089 # +0x8A 0x008A # +0x8B 0x008B # +0x8C 0x008C # +0x8D 0x008D # +0x8E 0x008E # +0x8F 0x008F # +0x90 0x0090 # +0x91 0x0091 # +0x92 0x0092 # +0x93 0x0093 # +0x94 0x0094 # +0x95 0x0095 # +0x96 0x0096 # +0x97 0x0097 # +0x98 0x0098 # +0x99 0x0099 # +0x9A 0x009A # +0x9B 0x009B # +0x9C 0x009C # +0x9D 0x009D # +0x9E 0x009E # +0x9F 0x009F # +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 diff --git a/extra/io/encodings/8-bit/8859-13.TXT b/extra/io/encodings/8-bit/8859-13.TXT new file mode 100644 index 0000000000..cd11b53fd7 --- /dev/null +++ b/extra/io/encodings/8-bit/8859-13.TXT @@ -0,0 +1,299 @@ +# +# 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 +# +# 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: +# +# +# Any comments or problems, contact +# Please note that 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 # +0x81 0x0081 # +0x82 0x0082 # +0x83 0x0083 # +0x84 0x0084 # +0x85 0x0085 # +0x86 0x0086 # +0x87 0x0087 # +0x88 0x0088 # +0x89 0x0089 # +0x8A 0x008A # +0x8B 0x008B # +0x8C 0x008C # +0x8D 0x008D # +0x8E 0x008E # +0x8F 0x008F # +0x90 0x0090 # +0x91 0x0091 # +0x92 0x0092 # +0x93 0x0093 # +0x94 0x0094 # +0x95 0x0095 # +0x96 0x0096 # +0x97 0x0097 # +0x98 0x0098 # +0x99 0x0099 # +0x9A 0x009A # +0x9B 0x009B # +0x9C 0x009C # +0x9D 0x009D # +0x9E 0x009E # +0x9F 0x009F # +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 diff --git a/extra/io/encodings/8-bit/8859-14.TXT b/extra/io/encodings/8-bit/8859-14.TXT new file mode 100644 index 0000000000..73e98555ea --- /dev/null +++ b/extra/io/encodings/8-bit/8859-14.TXT @@ -0,0 +1,301 @@ +# +# 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 +# Ken Whistler +# +# 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: +# +# +# Any comments or problems, contact +# Please note that 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 # +0x81 0x0081 # +0x82 0x0082 # +0x83 0x0083 # +0x84 0x0084 # +0x85 0x0085 # +0x86 0x0086 # +0x87 0x0087 # +0x88 0x0088 # +0x89 0x0089 # +0x8A 0x008A # +0x8B 0x008B # +0x8C 0x008C # +0x8D 0x008D # +0x8E 0x008E # +0x8F 0x008F # +0x90 0x0090 # +0x91 0x0091 # +0x92 0x0092 # +0x93 0x0093 # +0x94 0x0094 # +0x95 0x0095 # +0x96 0x0096 # +0x97 0x0097 # +0x98 0x0098 # +0x99 0x0099 # +0x9A 0x009A # +0x9B 0x009B # +0x9C 0x009C # +0x9D 0x009D # +0x9E 0x009E # +0x9F 0x009F # +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 + diff --git a/extra/io/encodings/8-bit/8859-15.TXT b/extra/io/encodings/8-bit/8859-15.TXT new file mode 100644 index 0000000000..ab2f32fcea --- /dev/null +++ b/extra/io/encodings/8-bit/8859-15.TXT @@ -0,0 +1,303 @@ +# +# 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 +# Ken Whistler +# +# 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: +# +# +# Any comments or problems, contact +# Please note that 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 # +0x81 0x0081 # +0x82 0x0082 # +0x83 0x0083 # +0x84 0x0084 # +0x85 0x0085 # +0x86 0x0086 # +0x87 0x0087 # +0x88 0x0088 # +0x89 0x0089 # +0x8A 0x008A # +0x8B 0x008B # +0x8C 0x008C # +0x8D 0x008D # +0x8E 0x008E # +0x8F 0x008F # +0x90 0x0090 # +0x91 0x0091 # +0x92 0x0092 # +0x93 0x0093 # +0x94 0x0094 # +0x95 0x0095 # +0x96 0x0096 # +0x97 0x0097 # +0x98 0x0098 # +0x99 0x0099 # +0x9A 0x009A # +0x9B 0x009B # +0x9C 0x009C # +0x9D 0x009D # +0x9E 0x009E # +0x9F 0x009F # +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 + diff --git a/extra/io/encodings/8-bit/8859-16.TXT b/extra/io/encodings/8-bit/8859-16.TXT new file mode 100644 index 0000000000..c0dcf0dac6 --- /dev/null +++ b/extra/io/encodings/8-bit/8859-16.TXT @@ -0,0 +1,299 @@ +# +# 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 +# +# 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: +# +# +# Any comments or problems, contact +# Please note that 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 # +0x81 0x0081 # +0x82 0x0082 # +0x83 0x0083 # +0x84 0x0084 # +0x85 0x0085 # +0x86 0x0086 # +0x87 0x0087 # +0x88 0x0088 # +0x89 0x0089 # +0x8A 0x008A # +0x8B 0x008B # +0x8C 0x008C # +0x8D 0x008D # +0x8E 0x008E # +0x8F 0x008F # +0x90 0x0090 # +0x91 0x0091 # +0x92 0x0092 # +0x93 0x0093 # +0x94 0x0094 # +0x95 0x0095 # +0x96 0x0096 # +0x97 0x0097 # +0x98 0x0098 # +0x99 0x0099 # +0x9A 0x009A # +0x9B 0x009B # +0x9C 0x009C # +0x9D 0x009D # +0x9E 0x009E # +0x9F 0x009F # +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 diff --git a/extra/io/encodings/8-bit/8859-2.TXT b/extra/io/encodings/8-bit/8859-2.TXT new file mode 100644 index 0000000000..e45df25eb8 --- /dev/null +++ b/extra/io/encodings/8-bit/8859-2.TXT @@ -0,0 +1,303 @@ +# +# 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 +# +# 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: +# +# +# Any comments or problems, contact +# Please note that 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 # +0x81 0x0081 # +0x82 0x0082 # +0x83 0x0083 # +0x84 0x0084 # +0x85 0x0085 # +0x86 0x0086 # +0x87 0x0087 # +0x88 0x0088 # +0x89 0x0089 # +0x8A 0x008A # +0x8B 0x008B # +0x8C 0x008C # +0x8D 0x008D # +0x8E 0x008E # +0x8F 0x008F # +0x90 0x0090 # +0x91 0x0091 # +0x92 0x0092 # +0x93 0x0093 # +0x94 0x0094 # +0x95 0x0095 # +0x96 0x0096 # +0x97 0x0097 # +0x98 0x0098 # +0x99 0x0099 # +0x9A 0x009A # +0x9B 0x009B # +0x9C 0x009C # +0x9D 0x009D # +0x9E 0x009E # +0x9F 0x009F # +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 diff --git a/extra/io/encodings/8-bit/8859-3.TXT b/extra/io/encodings/8-bit/8859-3.TXT new file mode 100644 index 0000000000..9b6ac69dd8 --- /dev/null +++ b/extra/io/encodings/8-bit/8859-3.TXT @@ -0,0 +1,296 @@ +# +# 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 +# +# 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: +# +# +# Any comments or problems, contact +# Please note that 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 # +0x81 0x0081 # +0x82 0x0082 # +0x83 0x0083 # +0x84 0x0084 # +0x85 0x0085 # +0x86 0x0086 # +0x87 0x0087 # +0x88 0x0088 # +0x89 0x0089 # +0x8A 0x008A # +0x8B 0x008B # +0x8C 0x008C # +0x8D 0x008D # +0x8E 0x008E # +0x8F 0x008F # +0x90 0x0090 # +0x91 0x0091 # +0x92 0x0092 # +0x93 0x0093 # +0x94 0x0094 # +0x95 0x0095 # +0x96 0x0096 # +0x97 0x0097 # +0x98 0x0098 # +0x99 0x0099 # +0x9A 0x009A # +0x9B 0x009B # +0x9C 0x009C # +0x9D 0x009D # +0x9E 0x009E # +0x9F 0x009F # +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 diff --git a/extra/io/encodings/8-bit/8859-4.TXT b/extra/io/encodings/8-bit/8859-4.TXT new file mode 100644 index 0000000000..662e698ab2 --- /dev/null +++ b/extra/io/encodings/8-bit/8859-4.TXT @@ -0,0 +1,303 @@ +# +# 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 +# +# 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: +# +# +# Any comments or problems, contact +# Please note that 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 # +0x81 0x0081 # +0x82 0x0082 # +0x83 0x0083 # +0x84 0x0084 # +0x85 0x0085 # +0x86 0x0086 # +0x87 0x0087 # +0x88 0x0088 # +0x89 0x0089 # +0x8A 0x008A # +0x8B 0x008B # +0x8C 0x008C # +0x8D 0x008D # +0x8E 0x008E # +0x8F 0x008F # +0x90 0x0090 # +0x91 0x0091 # +0x92 0x0092 # +0x93 0x0093 # +0x94 0x0094 # +0x95 0x0095 # +0x96 0x0096 # +0x97 0x0097 # +0x98 0x0098 # +0x99 0x0099 # +0x9A 0x009A # +0x9B 0x009B # +0x9C 0x009C # +0x9D 0x009D # +0x9E 0x009E # +0x9F 0x009F # +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 diff --git a/extra/io/encodings/8-bit/8859-5.TXT b/extra/io/encodings/8-bit/8859-5.TXT new file mode 100644 index 0000000000..a7ed1ce2ab --- /dev/null +++ b/extra/io/encodings/8-bit/8859-5.TXT @@ -0,0 +1,303 @@ +# +# 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 +# +# 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: +# +# +# Any comments or problems, contact +# Please note that 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 # +0x81 0x0081 # +0x82 0x0082 # +0x83 0x0083 # +0x84 0x0084 # +0x85 0x0085 # +0x86 0x0086 # +0x87 0x0087 # +0x88 0x0088 # +0x89 0x0089 # +0x8A 0x008A # +0x8B 0x008B # +0x8C 0x008C # +0x8D 0x008D # +0x8E 0x008E # +0x8F 0x008F # +0x90 0x0090 # +0x91 0x0091 # +0x92 0x0092 # +0x93 0x0093 # +0x94 0x0094 # +0x95 0x0095 # +0x96 0x0096 # +0x97 0x0097 # +0x98 0x0098 # +0x99 0x0099 # +0x9A 0x009A # +0x9B 0x009B # +0x9C 0x009C # +0x9D 0x009D # +0x9E 0x009E # +0x9F 0x009F # +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 diff --git a/extra/io/encodings/8-bit/8859-6.TXT b/extra/io/encodings/8-bit/8859-6.TXT new file mode 100644 index 0000000000..69ac7f5894 --- /dev/null +++ b/extra/io/encodings/8-bit/8859-6.TXT @@ -0,0 +1,260 @@ +# +# 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 +# +# 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: +# +# +# Any comments or problems, contact +# Please note that 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 # +0x81 0x0081 # +0x82 0x0082 # +0x83 0x0083 # +0x84 0x0084 # +0x85 0x0085 # +0x86 0x0086 # +0x87 0x0087 # +0x88 0x0088 # +0x89 0x0089 # +0x8A 0x008A # +0x8B 0x008B # +0x8C 0x008C # +0x8D 0x008D # +0x8E 0x008E # +0x8F 0x008F # +0x90 0x0090 # +0x91 0x0091 # +0x92 0x0092 # +0x93 0x0093 # +0x94 0x0094 # +0x95 0x0095 # +0x96 0x0096 # +0x97 0x0097 # +0x98 0x0098 # +0x99 0x0099 # +0x9A 0x009A # +0x9B 0x009B # +0x9C 0x009C # +0x9D 0x009D # +0x9E 0x009E # +0x9F 0x009F # +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 diff --git a/extra/io/encodings/8-bit/8859-7.TXT b/extra/io/encodings/8-bit/8859-7.TXT new file mode 100644 index 0000000000..bc46b74719 --- /dev/null +++ b/extra/io/encodings/8-bit/8859-7.TXT @@ -0,0 +1,308 @@ +# +# 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 +# +# 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: +# +# +# Any comments or problems, contact the Unicode Consortium at: +# +# +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 # +0x81 0x0081 # +0x82 0x0082 # +0x83 0x0083 # +0x84 0x0084 # +0x85 0x0085 # +0x86 0x0086 # +0x87 0x0087 # +0x88 0x0088 # +0x89 0x0089 # +0x8A 0x008A # +0x8B 0x008B # +0x8C 0x008C # +0x8D 0x008D # +0x8E 0x008E # +0x8F 0x008F # +0x90 0x0090 # +0x91 0x0091 # +0x92 0x0092 # +0x93 0x0093 # +0x94 0x0094 # +0x95 0x0095 # +0x96 0x0096 # +0x97 0x0097 # +0x98 0x0098 # +0x99 0x0099 # +0x9A 0x009A # +0x9B 0x009B # +0x9C 0x009C # +0x9D 0x009D # +0x9E 0x009E # +0x9F 0x009F # +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 diff --git a/extra/io/encodings/8-bit/8859-8.TXT b/extra/io/encodings/8-bit/8859-8.TXT new file mode 100644 index 0000000000..bc8da4c7fd --- /dev/null +++ b/extra/io/encodings/8-bit/8859-8.TXT @@ -0,0 +1,270 @@ +# +# 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 +# +# 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: +# +# +# Any comments or problems, contact +# Please note that 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 # +0x81 0x0081 # +0x82 0x0082 # +0x83 0x0083 # +0x84 0x0084 # +0x85 0x0085 # +0x86 0x0086 # +0x87 0x0087 # +0x88 0x0088 # +0x89 0x0089 # +0x8A 0x008A # +0x8B 0x008B # +0x8C 0x008C # +0x8D 0x008D # +0x8E 0x008E # +0x8F 0x008F # +0x90 0x0090 # +0x91 0x0091 # +0x92 0x0092 # +0x93 0x0093 # +0x94 0x0094 # +0x95 0x0095 # +0x96 0x0096 # +0x97 0x0097 # +0x98 0x0098 # +0x99 0x0099 # +0x9A 0x009A # +0x9B 0x009B # +0x9C 0x009C # +0x9D 0x009D # +0x9E 0x009E # +0x9F 0x009F # +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 + diff --git a/extra/io/encodings/8-bit/8859-9.TXT b/extra/io/encodings/8-bit/8859-9.TXT new file mode 100644 index 0000000000..22901f1077 --- /dev/null +++ b/extra/io/encodings/8-bit/8859-9.TXT @@ -0,0 +1,307 @@ +# +# 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 +# +# 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: +# +# +# Any comments or problems, contact +# Please note that 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 # +0x81 0x0081 # +0x82 0x0082 # +0x83 0x0083 # +0x84 0x0084 # +0x85 0x0085 # +0x86 0x0086 # +0x87 0x0087 # +0x88 0x0088 # +0x89 0x0089 # +0x8A 0x008A # +0x8B 0x008B # +0x8C 0x008C # +0x8D 0x008D # +0x8E 0x008E # +0x8F 0x008F # +0x90 0x0090 # +0x91 0x0091 # +0x92 0x0092 # +0x93 0x0093 # +0x94 0x0094 # +0x95 0x0095 # +0x96 0x0096 # +0x97 0x0097 # +0x98 0x0098 # +0x99 0x0099 # +0x9A 0x009A # +0x9B 0x009B # +0x9C 0x009C # +0x9D 0x009D # +0x9E 0x009E # +0x9F 0x009F # +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 + + diff --git a/extra/io/encodings/8-bit/CP037.TXT b/extra/io/encodings/8-bit/CP037.TXT new file mode 100644 index 0000000000..48fde2ae69 --- /dev/null +++ b/extra/io/encodings/8-bit/CP037.TXT @@ -0,0 +1,275 @@ +# +# 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 + + \ No newline at end of file diff --git a/extra/io/encodings/8-bit/CP1252.TXT b/extra/io/encodings/8-bit/CP1252.TXT new file mode 100644 index 0000000000..8ff4b204b7 --- /dev/null +++ b/extra/io/encodings/8-bit/CP1252.TXT @@ -0,0 +1,274 @@ +# +# 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 diff --git a/extra/io/encodings/8-bit/GSM0338.TXT b/extra/io/encodings/8-bit/GSM0338.TXT new file mode 100644 index 0000000000..ae804d635a --- /dev/null +++ b/extra/io/encodings/8-bit/GSM0338.TXT @@ -0,0 +1,239 @@ +# +# Name: GSM 03.38 to Unicode +# Unicode version: 3.0 +# Table version: 1.1 +# Table format: Format A +# Date: 2000 May 30 +# Authors: Ken Whistler +# Kent Karlsson +# Markus Kuhn +# +# Copyright (c) 2000 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 +# ETSI GSM 03.38 7-bit default alphabet characters map into Unicode. +# This mapping is based on ETSI TS 100 900 V7.2.0 (1999-07), with +# a correction of 0x09 to *small* c-cedilla, instead of *capital* +# C-cedilla. +# +# Format: Three tab-separated columns +# Column #1 is the ETSI GSM 03.38 7-bit default alphabet +# code (in hex as 0xXX, or 0xXXXX for double-byte +# sequences) +# Column #2 is the Unicode scalar value (in hex as 0xXXXX) +# Column #3 the Unicode name (follows a comment sign, '#') +# +# The entries are in ETSI GSM 03.38 7-bit default alphabet code order. +# +# Note that ETSI GSM 03.38 also allows for the use of UCS-2 (UTF-16 +# restricted to the BMP) in GSM/SMS messages. +# +# Note also that there are commented Greek mappings for some +# capital Latin characters. This follows from the clear intent +# of the ETSI GSM 03.38 to have glyph coverage for the uppercase +# Greek alphabet by reusing Latin letters that have the same +# form as an uppercase Greek letter. Conversion implementations +# should be aware of this fact. +# +# The ETSI GSM 03.38 specification shows an uppercase C-cedilla +# glyph at 0x09. This may be the result of limited display +# capabilities for handling characters with descenders. However, the +# language coverage intent is clearly for the lowercase c-cedilla, as shown +# in the mapping below. The mapping for uppercase C-cedilla is shown +# in a commented line in the mapping table. +# +# The ESC character 0x1B is +# mapped to the no-break space character, unless it is part of a +# valid ESC sequence, to facilitate round-trip compatibility in +# the presence of unknown ESC sequences. +# +# 0x00 is NULL (when followed only by 0x00 up to the +# end of (fixed byte length) message, possibly also up to +# FORM FEED. But 0x00 is also the code for COMMERCIAL AT +# when some other character (CARRIAGE RETURN if nothing else) +# comes after the 0x00. +# +# Version history +# 1.0 version: first creation +# 1.1 version: fixed problem with the wrong line being a comment, +# added text regarding 0x00's interpretation, +# added second mapping for C-cedilla, +# added mapping of 0x1B escape to NBSP for display. +# +# Updated versions of this file may be found in: +# +# +# Any comments or problems, contact +# Please note that is an archival address; +# notices will be checked, but do not expect an immediate response. +# +0x00 0x0040 # COMMERCIAL AT +#0x00 0x0000 # NULL (see note above) +0x01 0x00A3 # POUND SIGN +0x02 0x0024 # DOLLAR SIGN +0x03 0x00A5 # YEN SIGN +0x04 0x00E8 # LATIN SMALL LETTER E WITH GRAVE +0x05 0x00E9 # LATIN SMALL LETTER E WITH ACUTE +0x06 0x00F9 # LATIN SMALL LETTER U WITH GRAVE +0x07 0x00EC # LATIN SMALL LETTER I WITH GRAVE +0x08 0x00F2 # LATIN SMALL LETTER O WITH GRAVE +0x09 0x00E7 # LATIN SMALL LETTER C WITH CEDILLA +#0x09 0x00C7 # LATIN CAPITAL LETTER C WITH CEDILLA (see note above) +0x0A 0x000A # LINE FEED +0x0B 0x00D8 # LATIN CAPITAL LETTER O WITH STROKE +0x0C 0x00F8 # LATIN SMALL LETTER O WITH STROKE +0x0D 0x000D # CARRIAGE RETURN +0x0E 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE +0x0F 0x00E5 # LATIN SMALL LETTER A WITH RING ABOVE +0x10 0x0394 # GREEK CAPITAL LETTER DELTA +0x11 0x005F # LOW LINE +0x12 0x03A6 # GREEK CAPITAL LETTER PHI +0x13 0x0393 # GREEK CAPITAL LETTER GAMMA +0x14 0x039B # GREEK CAPITAL LETTER LAMDA +0x15 0x03A9 # GREEK CAPITAL LETTER OMEGA +0x16 0x03A0 # GREEK CAPITAL LETTER PI +0x17 0x03A8 # GREEK CAPITAL LETTER PSI +0x18 0x03A3 # GREEK CAPITAL LETTER SIGMA +0x19 0x0398 # GREEK CAPITAL LETTER THETA +0x1A 0x039E # GREEK CAPITAL LETTER XI +0x1B 0x00A0 # ESCAPE TO EXTENSION TABLE (or displayed as NBSP, see note above) +0x1B0A 0x000C # FORM FEED +0x1B14 0x005E # CIRCUMFLEX ACCENT +0x1B28 0x007B # LEFT CURLY BRACKET +0x1B29 0x007D # RIGHT CURLY BRACKET +0x1B2F 0x005C # REVERSE SOLIDUS +0x1B3C 0x005B # LEFT SQUARE BRACKET +0x1B3D 0x007E # TILDE +0x1B3E 0x005D # RIGHT SQUARE BRACKET +0x1B40 0x007C # VERTICAL LINE +0x1B65 0x20AC # EURO SIGN +0x1C 0x00C6 # LATIN CAPITAL LETTER AE +0x1D 0x00E6 # LATIN SMALL LETTER AE +0x1E 0x00DF # LATIN SMALL LETTER SHARP S (German) +0x1F 0x00C9 # LATIN CAPITAL LETTER E WITH ACUTE +0x20 0x0020 # SPACE +0x21 0x0021 # EXCLAMATION MARK +0x22 0x0022 # QUOTATION MARK +0x23 0x0023 # NUMBER SIGN +0x24 0x00A4 # CURRENCY 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 0x00A1 # INVERTED EXCLAMATION MARK +0x41 0x0041 # LATIN CAPITAL LETTER A +#0x41 0x0391 # GREEK CAPITAL LETTER ALPHA +0x42 0x0042 # LATIN CAPITAL LETTER B +#0x42 0x0392 # GREEK CAPITAL LETTER BETA +0x43 0x0043 # LATIN CAPITAL LETTER C +0x44 0x0044 # LATIN CAPITAL LETTER D +0x45 0x0045 # LATIN CAPITAL LETTER E +#0x45 0x0395 # GREEK CAPITAL LETTER EPSILON +0x46 0x0046 # LATIN CAPITAL LETTER F +0x47 0x0047 # LATIN CAPITAL LETTER G +0x48 0x0048 # LATIN CAPITAL LETTER H +#0x48 0x0397 # GREEK CAPITAL LETTER ETA +0x49 0x0049 # LATIN CAPITAL LETTER I +#0x49 0x0399 # GREEK CAPITAL LETTER IOTA +0x4A 0x004A # LATIN CAPITAL LETTER J +0x4B 0x004B # LATIN CAPITAL LETTER K +#0x4B 0x039A # GREEK CAPITAL LETTER KAPPA +0x4C 0x004C # LATIN CAPITAL LETTER L +0x4D 0x004D # LATIN CAPITAL LETTER M +#0x4D 0x039C # GREEK CAPITAL LETTER MU +0x4E 0x004E # LATIN CAPITAL LETTER N +#0x4E 0x039D # GREEK CAPITAL LETTER NU +0x4F 0x004F # LATIN CAPITAL LETTER O +#0x4F 0x039F # GREEK CAPITAL LETTER OMICRON +0x50 0x0050 # LATIN CAPITAL LETTER P +#0x50 0x03A1 # GREEK CAPITAL LETTER RHO +0x51 0x0051 # LATIN CAPITAL LETTER Q +0x52 0x0052 # LATIN CAPITAL LETTER R +0x53 0x0053 # LATIN CAPITAL LETTER S +0x54 0x0054 # LATIN CAPITAL LETTER T +#0x54 0x03A4 # GREEK CAPITAL LETTER TAU +0x55 0x0055 # LATIN CAPITAL LETTER U +#0x55 0x03A5 # GREEK CAPITAL LETTER UPSILON +0x56 0x0056 # LATIN CAPITAL LETTER V +0x57 0x0057 # LATIN CAPITAL LETTER W +0x58 0x0058 # LATIN CAPITAL LETTER X +#0x58 0x03A7 # GREEK CAPITAL LETTER CHI +0x59 0x0059 # LATIN CAPITAL LETTER Y +0x5A 0x005A # LATIN CAPITAL LETTER Z +#0x5A 0x0396 # GREEK CAPITAL LETTER ZETA +0x5B 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS +0x5C 0x00D6 # LATIN CAPITAL LETTER O WITH DIAERESIS +0x5D 0x00D1 # LATIN CAPITAL LETTER N WITH TILDE +0x5E 0x00DC # LATIN CAPITAL LETTER U WITH DIAERESIS +0x5F 0x00A7 # SECTION SIGN +0x60 0x00BF # INVERTED QUESTION MARK +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 0x00E4 # LATIN SMALL LETTER A WITH DIAERESIS +0x7C 0x00F6 # LATIN SMALL LETTER O WITH DIAERESIS +0x7D 0x00F1 # LATIN SMALL LETTER N WITH TILDE +0x7E 0x00FC # LATIN SMALL LETTER U WITH DIAERESIS +0x7F 0x00E0 # LATIN SMALL LETTER A WITH GRAVE diff --git a/extra/io/encodings/8-bit/KOI8-R.TXT b/extra/io/encodings/8-bit/KOI8-R.TXT new file mode 100644 index 0000000000..510561005c --- /dev/null +++ b/extra/io/encodings/8-bit/KOI8-R.TXT @@ -0,0 +1,302 @@ +# +# 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 +# +# 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 +# Please note that 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 diff --git a/extra/io/encodings/8-bit/ROMAN.TXT b/extra/io/encodings/8-bit/ROMAN.TXT new file mode 100644 index 0000000000..5b3b8b4005 --- /dev/null +++ b/extra/io/encodings/8-bit/ROMAN.TXT @@ -0,0 +1,370 @@ +#======================================================================= +# 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 +# and Text Encoding Converter 2.0. +# b4,c1 2002-Dec-19 Update URLs, notes. Matches internal +# utom. +# b03 1999-Sep-22 Update contact e-mail address. Matches +# internal utom, ufrm, 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, +# ufrm. +# 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, ufrm: +# 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. +# +# 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: +# +# +# +# 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 diff --git a/extra/io/encodings/latin1/authors.txt b/extra/io/encodings/8-bit/authors.txt similarity index 100% rename from extra/io/encodings/latin1/authors.txt rename to extra/io/encodings/8-bit/authors.txt diff --git a/extra/io/encodings/8-bit/summary.txt b/extra/io/encodings/8-bit/summary.txt new file mode 100644 index 0000000000..7fe8064015 --- /dev/null +++ b/extra/io/encodings/8-bit/summary.txt @@ -0,0 +1 @@ +Definitions of 8-bit encodings like ISO 8859 and Windows 1252 diff --git a/extra/io/encodings/latin1/tags.txt b/extra/io/encodings/8-bit/tags.txt similarity index 100% rename from extra/io/encodings/latin1/tags.txt rename to extra/io/encodings/8-bit/tags.txt diff --git a/extra/io/encodings/latin1/latin1-docs.factor b/extra/io/encodings/latin1/latin1-docs.factor deleted file mode 100644 index 5872b2bcfd..0000000000 --- a/extra/io/encodings/latin1/latin1-docs.factor +++ /dev/null @@ -1,5 +0,0 @@ -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" } ; diff --git a/extra/io/encodings/latin1/latin1-tests.factor b/extra/io/encodings/latin1/latin1-tests.factor deleted file mode 100644 index a89bfe0e6f..0000000000 --- a/extra/io/encodings/latin1/latin1-tests.factor +++ /dev/null @@ -1,9 +0,0 @@ -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 diff --git a/extra/io/encodings/latin1/latin1.factor b/extra/io/encodings/latin1/latin1.factor deleted file mode 100755 index 2b82318885..0000000000 --- a/extra/io/encodings/latin1/latin1.factor +++ /dev/null @@ -1,12 +0,0 @@ -! Copyright (C) 2008 Daniel Ehrenberg. -! See http://factorcode.org/license.txt for BSD license. -USING: io io.encodings kernel io.encodings.ascii.private ; -IN: io.encodings.latin1 - -TUPLE: latin1 ; - -M: latin1 encode-char - 256 encode-if< ; - -M: latin1 decode-char - drop stream-read1 ; diff --git a/extra/io/encodings/latin1/summary.txt b/extra/io/encodings/latin1/summary.txt deleted file mode 100644 index d40d628767..0000000000 --- a/extra/io/encodings/latin1/summary.txt +++ /dev/null @@ -1 +0,0 @@ -ISO 8859-1 encoding/decoding From 9018a9093fd4f2f39d942bf9d369f4667a4b57d5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 21 Mar 2008 11:52:47 -0600 Subject: [PATCH 136/886] fix using --- extra/io/windows/files/unique/unique.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor index 112dea48a7..7e7610eb72 100644 --- a/extra/io/windows/files/unique/unique.factor +++ b/extra/io/windows/files/unique/unique.factor @@ -1,5 +1,5 @@ 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 -- ) From 7adef0c61321a004bf93d0fb3c1241b75a4a44c1 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 21 Mar 2008 14:01:50 -0400 Subject: [PATCH 137/886] Completing 8-bit changes --- extra/io/encodings/8-bit/8-bit-tests.factor | 1 + extra/io/encodings/8-bit/8-bit.factor | 18 +- extra/io/encodings/8-bit/GSM0338.TXT | 239 -------------------- 3 files changed, 12 insertions(+), 246 deletions(-) delete mode 100644 extra/io/encodings/8-bit/GSM0338.TXT diff --git a/extra/io/encodings/8-bit/8-bit-tests.factor b/extra/io/encodings/8-bit/8-bit-tests.factor index 316e496219..5dbe28cb14 100644 --- a/extra/io/encodings/8-bit/8-bit-tests.factor +++ b/extra/io/encodings/8-bit/8-bit-tests.factor @@ -7,3 +7,4 @@ IN: io.encodings.8-bit.tests [ "bar" ] [ "bar" iso-8859-1 decode ] unit-test [ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } iso-8859-1 decode >array ] unit-test +[ { HEX: fffd HEX: 20AC } ] [ { HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index ff0e6ec8bf..2cc6b2e57c 100644 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -3,7 +3,7 @@ USING: math.parser arrays io.encodings sequences kernel assocs hashtables io.encodings.ascii combinators.cleave generic parser tuples words io io.files splitting namespaces -classes quotations ; +classes quotations math compiler.units ; IN: io.encodings.8-bit ] map ] map ; + [ "\t " split 2 head [ 2 tail-if hex> ] map ] map ; : byte>ch ( assoc -- array ) 256 replacement-char @@ -73,7 +75,9 @@ IN: io.encodings.8-bit \ encode-char [ encode-8-bit ] method-with-data ; : decode-8-bit ( stream encoding array -- char/f ) - nip swap stream-read1 [ swap nth ] [ drop f ] if* ; + nip swap stream-read1 + [ swap nth [ replacement-char ] unless* ] + [ drop f ] if* ; : define-decode-char ( class array -- ) \ decode-char [ decode-8-bit ] method-with-data ; @@ -86,4 +90,4 @@ IN: io.encodings.8-bit PRIVATE> -! << mappings [ define-8-bit-encoding ] assoc-each >> +[ mappings [ define-8-bit-encoding ] assoc-each ] with-compilation-unit diff --git a/extra/io/encodings/8-bit/GSM0338.TXT b/extra/io/encodings/8-bit/GSM0338.TXT deleted file mode 100644 index ae804d635a..0000000000 --- a/extra/io/encodings/8-bit/GSM0338.TXT +++ /dev/null @@ -1,239 +0,0 @@ -# -# Name: GSM 03.38 to Unicode -# Unicode version: 3.0 -# Table version: 1.1 -# Table format: Format A -# Date: 2000 May 30 -# Authors: Ken Whistler -# Kent Karlsson -# Markus Kuhn -# -# Copyright (c) 2000 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 -# ETSI GSM 03.38 7-bit default alphabet characters map into Unicode. -# This mapping is based on ETSI TS 100 900 V7.2.0 (1999-07), with -# a correction of 0x09 to *small* c-cedilla, instead of *capital* -# C-cedilla. -# -# Format: Three tab-separated columns -# Column #1 is the ETSI GSM 03.38 7-bit default alphabet -# code (in hex as 0xXX, or 0xXXXX for double-byte -# sequences) -# Column #2 is the Unicode scalar value (in hex as 0xXXXX) -# Column #3 the Unicode name (follows a comment sign, '#') -# -# The entries are in ETSI GSM 03.38 7-bit default alphabet code order. -# -# Note that ETSI GSM 03.38 also allows for the use of UCS-2 (UTF-16 -# restricted to the BMP) in GSM/SMS messages. -# -# Note also that there are commented Greek mappings for some -# capital Latin characters. This follows from the clear intent -# of the ETSI GSM 03.38 to have glyph coverage for the uppercase -# Greek alphabet by reusing Latin letters that have the same -# form as an uppercase Greek letter. Conversion implementations -# should be aware of this fact. -# -# The ETSI GSM 03.38 specification shows an uppercase C-cedilla -# glyph at 0x09. This may be the result of limited display -# capabilities for handling characters with descenders. However, the -# language coverage intent is clearly for the lowercase c-cedilla, as shown -# in the mapping below. The mapping for uppercase C-cedilla is shown -# in a commented line in the mapping table. -# -# The ESC character 0x1B is -# mapped to the no-break space character, unless it is part of a -# valid ESC sequence, to facilitate round-trip compatibility in -# the presence of unknown ESC sequences. -# -# 0x00 is NULL (when followed only by 0x00 up to the -# end of (fixed byte length) message, possibly also up to -# FORM FEED. But 0x00 is also the code for COMMERCIAL AT -# when some other character (CARRIAGE RETURN if nothing else) -# comes after the 0x00. -# -# Version history -# 1.0 version: first creation -# 1.1 version: fixed problem with the wrong line being a comment, -# added text regarding 0x00's interpretation, -# added second mapping for C-cedilla, -# added mapping of 0x1B escape to NBSP for display. -# -# Updated versions of this file may be found in: -# -# -# Any comments or problems, contact -# Please note that is an archival address; -# notices will be checked, but do not expect an immediate response. -# -0x00 0x0040 # COMMERCIAL AT -#0x00 0x0000 # NULL (see note above) -0x01 0x00A3 # POUND SIGN -0x02 0x0024 # DOLLAR SIGN -0x03 0x00A5 # YEN SIGN -0x04 0x00E8 # LATIN SMALL LETTER E WITH GRAVE -0x05 0x00E9 # LATIN SMALL LETTER E WITH ACUTE -0x06 0x00F9 # LATIN SMALL LETTER U WITH GRAVE -0x07 0x00EC # LATIN SMALL LETTER I WITH GRAVE -0x08 0x00F2 # LATIN SMALL LETTER O WITH GRAVE -0x09 0x00E7 # LATIN SMALL LETTER C WITH CEDILLA -#0x09 0x00C7 # LATIN CAPITAL LETTER C WITH CEDILLA (see note above) -0x0A 0x000A # LINE FEED -0x0B 0x00D8 # LATIN CAPITAL LETTER O WITH STROKE -0x0C 0x00F8 # LATIN SMALL LETTER O WITH STROKE -0x0D 0x000D # CARRIAGE RETURN -0x0E 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE -0x0F 0x00E5 # LATIN SMALL LETTER A WITH RING ABOVE -0x10 0x0394 # GREEK CAPITAL LETTER DELTA -0x11 0x005F # LOW LINE -0x12 0x03A6 # GREEK CAPITAL LETTER PHI -0x13 0x0393 # GREEK CAPITAL LETTER GAMMA -0x14 0x039B # GREEK CAPITAL LETTER LAMDA -0x15 0x03A9 # GREEK CAPITAL LETTER OMEGA -0x16 0x03A0 # GREEK CAPITAL LETTER PI -0x17 0x03A8 # GREEK CAPITAL LETTER PSI -0x18 0x03A3 # GREEK CAPITAL LETTER SIGMA -0x19 0x0398 # GREEK CAPITAL LETTER THETA -0x1A 0x039E # GREEK CAPITAL LETTER XI -0x1B 0x00A0 # ESCAPE TO EXTENSION TABLE (or displayed as NBSP, see note above) -0x1B0A 0x000C # FORM FEED -0x1B14 0x005E # CIRCUMFLEX ACCENT -0x1B28 0x007B # LEFT CURLY BRACKET -0x1B29 0x007D # RIGHT CURLY BRACKET -0x1B2F 0x005C # REVERSE SOLIDUS -0x1B3C 0x005B # LEFT SQUARE BRACKET -0x1B3D 0x007E # TILDE -0x1B3E 0x005D # RIGHT SQUARE BRACKET -0x1B40 0x007C # VERTICAL LINE -0x1B65 0x20AC # EURO SIGN -0x1C 0x00C6 # LATIN CAPITAL LETTER AE -0x1D 0x00E6 # LATIN SMALL LETTER AE -0x1E 0x00DF # LATIN SMALL LETTER SHARP S (German) -0x1F 0x00C9 # LATIN CAPITAL LETTER E WITH ACUTE -0x20 0x0020 # SPACE -0x21 0x0021 # EXCLAMATION MARK -0x22 0x0022 # QUOTATION MARK -0x23 0x0023 # NUMBER SIGN -0x24 0x00A4 # CURRENCY 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 0x00A1 # INVERTED EXCLAMATION MARK -0x41 0x0041 # LATIN CAPITAL LETTER A -#0x41 0x0391 # GREEK CAPITAL LETTER ALPHA -0x42 0x0042 # LATIN CAPITAL LETTER B -#0x42 0x0392 # GREEK CAPITAL LETTER BETA -0x43 0x0043 # LATIN CAPITAL LETTER C -0x44 0x0044 # LATIN CAPITAL LETTER D -0x45 0x0045 # LATIN CAPITAL LETTER E -#0x45 0x0395 # GREEK CAPITAL LETTER EPSILON -0x46 0x0046 # LATIN CAPITAL LETTER F -0x47 0x0047 # LATIN CAPITAL LETTER G -0x48 0x0048 # LATIN CAPITAL LETTER H -#0x48 0x0397 # GREEK CAPITAL LETTER ETA -0x49 0x0049 # LATIN CAPITAL LETTER I -#0x49 0x0399 # GREEK CAPITAL LETTER IOTA -0x4A 0x004A # LATIN CAPITAL LETTER J -0x4B 0x004B # LATIN CAPITAL LETTER K -#0x4B 0x039A # GREEK CAPITAL LETTER KAPPA -0x4C 0x004C # LATIN CAPITAL LETTER L -0x4D 0x004D # LATIN CAPITAL LETTER M -#0x4D 0x039C # GREEK CAPITAL LETTER MU -0x4E 0x004E # LATIN CAPITAL LETTER N -#0x4E 0x039D # GREEK CAPITAL LETTER NU -0x4F 0x004F # LATIN CAPITAL LETTER O -#0x4F 0x039F # GREEK CAPITAL LETTER OMICRON -0x50 0x0050 # LATIN CAPITAL LETTER P -#0x50 0x03A1 # GREEK CAPITAL LETTER RHO -0x51 0x0051 # LATIN CAPITAL LETTER Q -0x52 0x0052 # LATIN CAPITAL LETTER R -0x53 0x0053 # LATIN CAPITAL LETTER S -0x54 0x0054 # LATIN CAPITAL LETTER T -#0x54 0x03A4 # GREEK CAPITAL LETTER TAU -0x55 0x0055 # LATIN CAPITAL LETTER U -#0x55 0x03A5 # GREEK CAPITAL LETTER UPSILON -0x56 0x0056 # LATIN CAPITAL LETTER V -0x57 0x0057 # LATIN CAPITAL LETTER W -0x58 0x0058 # LATIN CAPITAL LETTER X -#0x58 0x03A7 # GREEK CAPITAL LETTER CHI -0x59 0x0059 # LATIN CAPITAL LETTER Y -0x5A 0x005A # LATIN CAPITAL LETTER Z -#0x5A 0x0396 # GREEK CAPITAL LETTER ZETA -0x5B 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS -0x5C 0x00D6 # LATIN CAPITAL LETTER O WITH DIAERESIS -0x5D 0x00D1 # LATIN CAPITAL LETTER N WITH TILDE -0x5E 0x00DC # LATIN CAPITAL LETTER U WITH DIAERESIS -0x5F 0x00A7 # SECTION SIGN -0x60 0x00BF # INVERTED QUESTION MARK -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 0x00E4 # LATIN SMALL LETTER A WITH DIAERESIS -0x7C 0x00F6 # LATIN SMALL LETTER O WITH DIAERESIS -0x7D 0x00F1 # LATIN SMALL LETTER N WITH TILDE -0x7E 0x00FC # LATIN SMALL LETTER U WITH DIAERESIS -0x7F 0x00E0 # LATIN SMALL LETTER A WITH GRAVE From 88baf7c3b7a7c38bb699e8ff72cb09fc6ce17031 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 21 Mar 2008 14:07:17 -0400 Subject: [PATCH 138/886] latin1 -> iso-8859-1 --- core/io/io-tests.factor | 4 ++-- .../benchmark/reverse-complement/reverse-complement.factor | 6 +++--- extra/http/client/client.factor | 6 +++--- extra/http/server/server.factor | 4 ++-- extra/io/unix/launcher/launcher.factor | 2 +- 5 files changed, 11 insertions(+), 11 deletions(-) diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 22c942d2d9..6200bd5235 100755 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,5 +1,5 @@ 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 @@ -9,7 +9,7 @@ IN: io.tests ] unit-test : ( resource -- stream ) - resource-path latin1 ; + resource-path iso-8859-1 ; [ "This is a line.\rThis is another line.\r" diff --git a/extra/benchmark/reverse-complement/reverse-complement.factor b/extra/benchmark/reverse-complement/reverse-complement.factor index 9c782e65e6..d83b720187 100755 --- a/extra/benchmark/reverse-complement/reverse-complement.factor +++ b/extra/benchmark/reverse-complement/reverse-complement.factor @@ -1,6 +1,6 @@ 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 ) @@ -32,8 +32,8 @@ HINTS: do-line vector string ; readln [ do-line (reverse-complement) ] [ show-seq ] if* ; : reverse-complement ( infile outfile -- ) - latin1 [ - swap latin1 [ + ascii [ + swap ascii [ swap [ 500000 (reverse-complement) ] with-stream diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index fc85cce3ad..233b61ea74 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -3,7 +3,7 @@ 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 ; IN: http.client DEFER: http-request @@ -52,7 +52,7 @@ PRIVATE> : http-request ( request -- response stream ) dup request [ - dup request-addr latin1 + dup request-addr iso-8859-1 1 minutes over set-timeout [ write-request flush @@ -82,7 +82,7 @@ PRIVATE> : download-to ( url file -- ) #! Downloads the contents of a URL to a file. swap http-get-stream swap check-response - [ swap latin1 stream-copy ] with-disposal ; + [ swap iso-8859-1 stream-copy ] with-disposal ; : download ( url -- ) dup download-name download-to ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 6b3ae52730..3df21adf26 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -4,7 +4,7 @@ USING: assocs kernel namespaces io io.timeouts strings splitting threads http sequences prettyprint io.server logging calendar 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 combinators.cleave ; IN: http.server GENERIC: call-responder ( path responder -- response ) @@ -217,7 +217,7 @@ SYMBOL: exit-continuation : httpd ( port -- ) internet-server "http.server" - latin1 [ handle-client ] with-server ; + iso-8859-1 [ handle-client ] with-server ; : httpd-main ( -- ) 8888 httpd ; diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index a1e42fddf2..8ed1c957af 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.nonblocking io.unix.backend 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 ; +io.unix.launcher.parser accessors ; IN: io.unix.launcher ! Search unix first From 17356ece95cbb36a4079799048a06dc54f6cbd2d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 21 Mar 2008 14:22:57 -0500 Subject: [PATCH 139/886] dont error on USE: unix --- extra/unix/types/types.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/unix/types/types.factor b/extra/unix/types/types.factor index ed2dbd5ba8..983d5d677d 100644 --- a/extra/unix/types/types.factor +++ b/extra/unix/types/types.factor @@ -12,5 +12,6 @@ os { "freebsd" [ "unix.types.freebsd" require ] } { "openbsd" [ "unix.types.openbsd" require ] } { "netbsd" [ "unix.types.netbsd" require ] } + { "winnt" [ ] } } case From 9c745c44d32284c4daf9d517429b96b4823f3d0b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 21 Mar 2008 14:53:11 -0500 Subject: [PATCH 140/886] add set-priority and get-priority add clear_err_no and check-errno for dealing with get-priority --- extra/io/priority/priority.factor | 5 +++++ extra/io/unix/backend/backend.factor | 3 +++ extra/io/unix/priority/priority.factor | 21 +++++++++++++++++++++ extra/io/unix/unix.factor | 2 +- extra/unix/unix.factor | 1 + vm/io.c | 5 +++++ vm/io.h | 1 + 7 files changed, 37 insertions(+), 1 deletion(-) create mode 100644 extra/io/priority/priority.factor create mode 100644 extra/io/unix/priority/priority.factor diff --git a/extra/io/priority/priority.factor b/extra/io/priority/priority.factor new file mode 100644 index 0000000000..0790563072 --- /dev/null +++ b/extra/io/priority/priority.factor @@ -0,0 +1,5 @@ +USING: io.backend kernel ; +IN: io.priority + +HOOK: get-priority io-backend ( -- n ) +HOOK: set-priority io-backend ( n -- ) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 93691c63e2..c9bd331bcd 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -72,6 +72,9 @@ M: mx 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 ; diff --git a/extra/io/unix/priority/priority.factor b/extra/io/unix/priority/priority.factor new file mode 100644 index 0000000000..deb801e3cf --- /dev/null +++ b/extra/io/unix/priority/priority.factor @@ -0,0 +1,21 @@ +USING: alien.syntax kernel io.priority io.unix.backend +unix ; +IN: io.unix.priority + +: 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 ) ; + +M: unix-io get-priority ( -- n ) + clear_err_no + 0 0 getpriority dup -1 = [ check-errno ] when ; + +M: unix-io set-priority ( n -- ) + 0 0 rot setpriority io-error ; diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index 1f0492a060..83a455c29a 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,5 +1,5 @@ USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts -io.unix.launcher io.unix.mmap io.backend +io.unix.launcher io.unix.mmap io.backend io.priority combinators namespaces system vocabs.loader sequences ; "io.unix." os append require diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index e1d49b8c6c..09d77fee11 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -27,6 +27,7 @@ TYPEDEF: ulong size_t ! ! ! Unix functions LIBRARY: factor FUNCTION: int err_no ( ) ; +FUNCTION: void clear_err_no ( ) ; LIBRARY: libc diff --git a/vm/io.c b/vm/io.c index faf681bbef..bc561f5e5b 100755 --- a/vm/io.c +++ b/vm/io.c @@ -194,3 +194,8 @@ int err_no(void) { return errno; } + +void clear_err_no(void) +{ + errno = 0; +} diff --git a/vm/io.h b/vm/io.h index 6291db50ee..f4af9b8bec 100755 --- a/vm/io.h +++ b/vm/io.h @@ -1,6 +1,7 @@ void init_c_io(void); void io_error(void); int err_no(void); +void clear_err_no(void); DECLARE_PRIMITIVE(fopen); DECLARE_PRIMITIVE(fgetc); From 08fe32a26865785c27aad5dc35eec1b69f370934 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 21 Mar 2008 15:25:18 -0500 Subject: [PATCH 141/886] fix priority loading --- extra/io/unix/unix.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index 83a455c29a..bd58761a5b 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,5 +1,5 @@ USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts -io.unix.launcher io.unix.mmap io.backend io.priority +io.unix.launcher io.unix.mmap io.backend io.unix.priority combinators namespaces system vocabs.loader sequences ; "io.unix." os append require From e60d8a49c1e676d357f7d84aa4cc8c3a56734342 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 21 Mar 2008 15:36:49 -0500 Subject: [PATCH 142/886] add more priority constants, priority functions --- extra/windows/kernel32/kernel32.factor | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 37b833cae1..22a86818cf 100644 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -189,6 +189,16 @@ TYPEDEF: FILE_NOTIFY_INFORMATION* PFILE_NOTIFY_INFORMATION : 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" } @@ -998,7 +1008,7 @@ FUNCTION: HMODULE GetModuleHandleW ( LPCWSTR lpModuleName ) ; ! 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 @@ -1065,8 +1075,8 @@ FUNCTION: UINT GetSystemWindowsDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ; ! 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 @@ -1437,9 +1447,9 @@ FUNCTION: BOOL SetHandleInformation ( HANDLE hObject, DWORD dwMask, DWORD dwFlag ! 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 @@ -1454,8 +1464,8 @@ FUNCTION: BOOL SetHandleInformation ( HANDLE hObject, DWORD dwMask, DWORD dwFlag ! 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 From fae69bd0920a1a53c411ff02b720585b9183c2c8 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 21 Mar 2008 16:57:13 -0400 Subject: [PATCH 143/886] Final fix for 8-bit encodings --- core/io/encodings/encodings-docs.factor | 9 +++++---- extra/io/encodings/8-bit/CP037.TXT | 2 -- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index 548d2cd7fc..5d1068d496 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -37,10 +37,11 @@ HELP: ( stream-in stream-out encoding -- duplex ) 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" } ; +{ $vocab-subsection "io.encodings.utf8" } +{ $vocab-subsection "io.encodings.ascii" } +{ $vocab-subsection "io.encodings.8-bit" } +{ $vocab-subsection "io.encodings.binary" } +{ $vocab-subsection "io.encodings.utf16" } ; 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." diff --git a/extra/io/encodings/8-bit/CP037.TXT b/extra/io/encodings/8-bit/CP037.TXT index 48fde2ae69..43186f7bf9 100644 --- a/extra/io/encodings/8-bit/CP037.TXT +++ b/extra/io/encodings/8-bit/CP037.TXT @@ -271,5 +271,3 @@ 0xFD 0x00D9 #LATIN CAPITAL LETTER U WITH GRAVE 0xFE 0x00DA #LATIN CAPITAL LETTER U WITH ACUTE 0xFF 0x009F #CONTROL - - \ No newline at end of file From 8d7ccf2596bfca71ed9d50849a70e4cc371d7f0a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 21 Mar 2008 17:48:01 -0500 Subject: [PATCH 144/886] Add unit test for ifte --- extra/combinators/lib/lib-tests.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index 0a08948346..ed481f72e6 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -46,3 +46,8 @@ IN: combinators.lib.tests [ dup array? ] [ dup vector? ] [ dup float? ] } || nip ] unit-test + + +{ 1 1 } [ + [ even? ] [ drop 1 ] [ drop 2 ] ifte +] must-infer-as From 86efc8467c1959725813b46edd6c7bc6e7ca6c89 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 21 Mar 2008 21:47:16 -0400 Subject: [PATCH 145/886] Strict wrapper for encodings --- extra/io/encodings/strict/authors.txt | 1 + extra/io/encodings/strict/strict-tests.factor | 6 ++++++ extra/io/encodings/strict/strict.factor | 18 ++++++++++++++++++ extra/io/encodings/strict/summary.txt | 1 + extra/io/encodings/strict/tags.txt | 1 + 5 files changed, 27 insertions(+) create mode 100644 extra/io/encodings/strict/authors.txt create mode 100644 extra/io/encodings/strict/strict-tests.factor create mode 100644 extra/io/encodings/strict/strict.factor create mode 100644 extra/io/encodings/strict/summary.txt create mode 100644 extra/io/encodings/strict/tags.txt diff --git a/extra/io/encodings/strict/authors.txt b/extra/io/encodings/strict/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/io/encodings/strict/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/io/encodings/strict/strict-tests.factor b/extra/io/encodings/strict/strict-tests.factor new file mode 100644 index 0000000000..aebb58cc30 --- /dev/null +++ b/extra/io/encodings/strict/strict-tests.factor @@ -0,0 +1,6 @@ +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 diff --git a/extra/io/encodings/strict/strict.factor b/extra/io/encodings/strict/strict.factor new file mode 100644 index 0000000000..89c10d89cc --- /dev/null +++ b/extra/io/encodings/strict/strict.factor @@ -0,0 +1,18 @@ +! 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 construct-empty throw ; +M: decode-error summary + drop "Error in decoding input stream" ; + +M: strict + code>> [ strict ] change-code ; + +M: strict decode-char + code>> decode-char dup replacement-char = [ decode-error ] when ; diff --git a/extra/io/encodings/strict/summary.txt b/extra/io/encodings/strict/summary.txt new file mode 100644 index 0000000000..9fd0fe3bf1 --- /dev/null +++ b/extra/io/encodings/strict/summary.txt @@ -0,0 +1 @@ +Strict wrapper for encodings diff --git a/extra/io/encodings/strict/tags.txt b/extra/io/encodings/strict/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/io/encodings/strict/tags.txt @@ -0,0 +1 @@ +text From bd89b4eb12e8a88ca540717c9a125b82a070a4f4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 21 Mar 2008 23:21:02 -0500 Subject: [PATCH 146/886] mmap constants --- build-support/grovel.c | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/build-support/grovel.c b/build-support/grovel.c index 600865cf39..8422ec197c 100644 --- a/build-support/grovel.c +++ b/build-support/grovel.c @@ -12,12 +12,18 @@ #define UNIX #endif -#if (__OpenBSD__) +#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 @@ -34,6 +40,7 @@ #include #include #include + #include #include #include #endif @@ -134,6 +141,10 @@ void unix_constants() constant(EINTR); constant(EAGAIN); constant(EINPROGRESS); + constant(PROT_READ); + constant(PROT_WRITE); + constant(MAP_FILE); + constant(MAP_SHARED); } int main() { From 3d1ba04462461f7d89fe3419b166f95bd56a9a89 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 22 Mar 2008 01:21:21 -0500 Subject: [PATCH 147/886] add remove-nth --- extra/sequences/lib/lib.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index a6b6b73148..0b93552e76 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -225,3 +225,6 @@ PRIVATE> : replace ( str oldseq newseq -- str' ) H{ } 2seq>assoc substitute ; + +: remove-nth ( seq n -- seq' ) + cut-slice 1 tail-slice append ; From d967d04e4cf961af1919b55620119381c2251ef7 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 23 Mar 2008 00:43:43 -0400 Subject: [PATCH 148/886] Changing 8-bit encoding names; documentation --- core/io/io-tests.factor | 2 +- extra/http/client/client.factor | 4 +- extra/http/server/server.factor | 2 +- extra/io/encodings/8-bit/8-bit-docs.factor | 91 ++++++++++++++++++++ extra/io/encodings/8-bit/8-bit-tests.factor | 10 +-- extra/io/encodings/8-bit/8-bit.factor | 36 ++++---- extra/io/encodings/strict/strict-docs.factor | 10 +++ 7 files changed, 128 insertions(+), 27 deletions(-) create mode 100644 extra/io/encodings/8-bit/8-bit-docs.factor create mode 100644 extra/io/encodings/strict/strict-docs.factor diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 91e51f25b0..abae63c82b 100755 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -9,7 +9,7 @@ IN: io.tests ] unit-test : ( resource -- stream ) - resource-path iso-8859-1 ; + resource-path latin1 ; [ "This is a line.\rThis is another line.\r" diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 233b61ea74..e4bbf0279f 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -52,7 +52,7 @@ PRIVATE> : http-request ( request -- response stream ) dup request [ - dup request-addr iso-8859-1 + dup request-addr latin1 1 minutes over set-timeout [ write-request flush @@ -82,7 +82,7 @@ PRIVATE> : download-to ( url file -- ) #! Downloads the contents of a URL to a file. swap http-get-stream swap check-response - [ swap iso-8859-1 stream-copy ] with-disposal ; + [ swap latin1 stream-copy ] with-disposal ; : download ( url -- ) dup download-name download-to ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 3df21adf26..81201dd3fe 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -217,7 +217,7 @@ SYMBOL: exit-continuation : httpd ( port -- ) internet-server "http.server" - iso-8859-1 [ handle-client ] with-server ; + latin1 [ handle-client ] with-server ; : httpd-main ( -- ) 8888 httpd ; diff --git a/extra/io/encodings/8-bit/8-bit-docs.factor b/extra/io/encodings/8-bit/8-bit-docs.factor new file mode 100644 index 0000000000..ff21094ba1 --- /dev/null +++ b/extra/io/encodings/8-bit/8-bit-docs.factor @@ -0,0 +1,91 @@ +! Copyright (C) 2008 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup io.encodings.8-bit.private ; +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 } +"Other encodings can be defined using the following utility" +{ $subsection define-8-bit-encoding } ; + +ABOUT: "io.encodings.8-bit" + +HELP: define-8-bit-encoding +{ $values { "name" "a string" } { "path" "a path" } } +{ $description "Creates a new encoding with the given name, using the resource file at the path to tell how to encode and decode octets. The resource file should be in a similar format to those at 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." } ; + +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." } ; + +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." } ; + +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." } ; + +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." } ; + +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." } ; + +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." } ; + +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." } ; + +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." } ; + +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." } ; + +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." } ; + +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." } ; + +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." } ; + +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." } ; + +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." } ; + +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." } ; + +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." } ; + +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." } ; + +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." } ; diff --git a/extra/io/encodings/8-bit/8-bit-tests.factor b/extra/io/encodings/8-bit/8-bit-tests.factor index 5dbe28cb14..24cd4137d4 100644 --- a/extra/io/encodings/8-bit/8-bit-tests.factor +++ b/extra/io/encodings/8-bit/8-bit-tests.factor @@ -1,10 +1,10 @@ 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" iso-8859-1 encode ] unit-test -[ { 256 } >string iso-8859-1 encode ] must-fail -[ B{ 255 } ] [ { 255 } iso-8859-1 encode ] unit-test +[ 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" iso-8859-1 decode ] unit-test -[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } iso-8859-1 decode >array ] 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 diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index 2cc6b2e57c..c041e699a2 100644 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -9,21 +9,21 @@ IN: io.encodings.8-bit hashtable ; : parse-file ( file-name -- byte>ch ch>byte ) - full-path ascii file-lines process-contents + ascii file-lines process-contents [ byte>ch ] [ ch>byte ] bi ; : empty-tuple-class ( string -- class ) @@ -85,9 +85,9 @@ IN: io.encodings.8-bit : 8-bit-methods ( class byte>ch ch>byte -- ) >r over r> define-encode-char define-decode-char ; -: define-8-bit-encoding ( tuple-name file-name -- ) +: define-8-bit-encoding ( name path -- ) >r empty-tuple-class r> parse-file 8-bit-methods ; PRIVATE> -[ mappings [ define-8-bit-encoding ] assoc-each ] with-compilation-unit +[ mappings [ full-path define-8-bit-encoding ] assoc-each ] with-compilation-unit diff --git a/extra/io/encodings/strict/strict-docs.factor b/extra/io/encodings/strict/strict-docs.factor new file mode 100644 index 0000000000..e8a4f18179 --- /dev/null +++ b/extra/io/encodings/strict/strict-docs.factor @@ -0,0 +1,10 @@ +! 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 From 78886019496045a8436df8c6f2c6777bc1396144 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 23 Mar 2008 00:58:17 -0400 Subject: [PATCH 149/886] Change to encodings docs --- core/io/encodings/encodings-docs.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index d5bdf24dc0..0f43bba0db 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -10,6 +10,7 @@ ARTICLE: "io.encodings" "I/O encodings" { $subsection "encodings-protocol" } ; ARTICLE: "encodings-constructors" "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." { $subsection } { $subsection } { $subsection } ; @@ -47,7 +48,7 @@ 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-char } { $subsection encode-char } -"The following methods are optional:" +"Optionally, an encoding can override the constructor words:" { $subsection } { $subsection } ; From 598127c0e2d1ca6d72fdbf0551c76ff4a0a306a7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Mar 2008 12:02:10 -0500 Subject: [PATCH 150/886] add new stack effects library --- extra/new-effects/new-effects.factor | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 extra/new-effects/new-effects.factor diff --git a/extra/new-effects/new-effects.factor b/extra/new-effects/new-effects.factor new file mode 100644 index 0000000000..dbb7b850d0 --- /dev/null +++ b/extra/new-effects/new-effects.factor @@ -0,0 +1,17 @@ +USING: assocs kernel sequences ; +IN: new-effects + +: new-nth ( seq n -- elt ) + swap nth ; + +: new-set-nth ( seq obj n -- seq ) + pick set-nth ; + +: new-at ( assoc key -- elt ) + swap at ; + +: new-at* ( assoc key -- elt ? ) + swap at* ; + +: new-set-at ( assoc value key -- assoc ) + pick set-at ; From c5cc14de917a420876fe8609872b91f5c12b3641 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Mar 2008 12:02:57 -0500 Subject: [PATCH 151/886] inline new-effects use new-effects for mersenne-twister --- extra/new-effects/new-effects.factor | 10 +++++----- extra/random/mersenne-twister/mersenne-twister.factor | 5 +---- 2 files changed, 6 insertions(+), 9 deletions(-) diff --git a/extra/new-effects/new-effects.factor b/extra/new-effects/new-effects.factor index dbb7b850d0..f073ccadd3 100644 --- a/extra/new-effects/new-effects.factor +++ b/extra/new-effects/new-effects.factor @@ -2,16 +2,16 @@ USING: assocs kernel sequences ; IN: new-effects : new-nth ( seq n -- elt ) - swap nth ; + swap nth ; inline : new-set-nth ( seq obj n -- seq ) - pick set-nth ; + pick set-nth ; inline : new-at ( assoc key -- elt ) - swap at ; + swap at ; inline : new-at* ( assoc key -- elt ? ) - swap at* ; + swap at* ; inline : new-set-at ( assoc value key -- assoc ) - pick set-at ; + pick set-at ; inline diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index bf2ff78f2d..ed515716e0 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -4,14 +4,11 @@ ! 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 combinators.cleave random ; +accessors math.ranges combinators.cleave random new-effects ; IN: random.mersenne-twister Date: Mon, 24 Mar 2008 17:19:22 -0500 Subject: [PATCH 152/886] fix bug in find-all-files --- extra/io/paths/paths.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index 6c73669e9f..dad1087022 100755 --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -44,7 +44,7 @@ TUPLE: directory-iterator path bfs queue ; : find-all-files ( path bfs? quot -- paths ) >r 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> ; From b68e79726ffee45639d7f0b46d2f4758084fac32 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Mar 2008 17:20:42 -0500 Subject: [PATCH 153/886] move priority bindings to extra/unix --- extra/unix/unix.factor | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 09d77fee11..8953b638f6 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -102,6 +102,17 @@ FUNCTION: int utimes ( char* path, timeval[2] times ) ; FUNCTION: int kill ( pid_t pid, int sig ) ; +: 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 From 1ff27e7de5f42914217cc1d2075ac1273143a406 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Mar 2008 17:25:03 -0500 Subject: [PATCH 154/886] rename process to priority --- extra/io/process/process.factor | 17 +++++++++++++++++ extra/io/unix/process/process.factor | 19 +++++++++++++++++++ extra/io/windows/process/priority.factor | 8 ++++++++ extra/io/windows/process/process.factor | 8 ++++++++ 4 files changed, 52 insertions(+) create mode 100644 extra/io/process/process.factor create mode 100644 extra/io/unix/process/process.factor create mode 100644 extra/io/windows/process/priority.factor create mode 100644 extra/io/windows/process/process.factor diff --git a/extra/io/process/process.factor b/extra/io/process/process.factor new file mode 100644 index 0000000000..8a7c5b1a11 --- /dev/null +++ b/extra/io/process/process.factor @@ -0,0 +1,17 @@ +USING: io.backend kernel ; +IN: io.priority + +SYMBOL: +lowest-priority+ +SYMBOL: +low-priority+ +SYMBOL: +normal-priority+ +SYMBOL: +high-priority+ +SYMBOL: +highest-priority+ + +HOOK: current-priority io-backend ( -- symbol ) +HOOK: set-current-priority io-backend ( symbol -- ) +HOOK: priority-values ( -- assoc ) + +: lookup-priority ( symbol -- n ) + priority-values at ; + +HOOK: get-process-list io-backend ( -- assoc ) diff --git a/extra/io/unix/process/process.factor b/extra/io/unix/process/process.factor new file mode 100644 index 0000000000..00df6b6f52 --- /dev/null +++ b/extra/io/unix/process/process.factor @@ -0,0 +1,19 @@ +USING: alien.syntax kernel io.process io.unix.backend +unix ; +IN: io.unix.process + +M: unix-io current-priority ( -- n ) + clear_err_no + 0 0 getpriority dup -1 = [ check-errno ] when ; + +M: unix-io set-current-priority ( n -- ) + 0 0 rot setpriority io-error ; + +M: unix-io priority-values ( -- assoc ) + { + { +lowest-priority+ 20 } + { +low-priority+ 10 } + { +normal-priority+ 0 } + { +high-priority+ -10 } + { +highest-priority+ -20 } + } ; diff --git a/extra/io/windows/process/priority.factor b/extra/io/windows/process/priority.factor new file mode 100644 index 0000000000..f0ca04fd8a --- /dev/null +++ b/extra/io/windows/process/priority.factor @@ -0,0 +1,8 @@ +USING: kernel ; +IN: io.windows.process + +M: windows-io current-priority ( -- n ) + ; + +M: windows-io set-current-priority ( n -- ) + ; diff --git a/extra/io/windows/process/process.factor b/extra/io/windows/process/process.factor new file mode 100644 index 0000000000..f0ca04fd8a --- /dev/null +++ b/extra/io/windows/process/process.factor @@ -0,0 +1,8 @@ +USING: kernel ; +IN: io.windows.process + +M: windows-io current-priority ( -- n ) + ; + +M: windows-io set-current-priority ( n -- ) + ; From fd0d489543d8a577975aba46a1db46fa3c55d0af Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Mar 2008 17:25:19 -0500 Subject: [PATCH 155/886] finish rename process to priority --- extra/io/priority/priority.factor | 5 ----- extra/io/unix/priority/priority.factor | 21 --------------------- extra/io/unix/unix.factor | 2 +- extra/io/windows/process/priority.factor | 8 -------- 4 files changed, 1 insertion(+), 35 deletions(-) delete mode 100644 extra/io/priority/priority.factor delete mode 100644 extra/io/unix/priority/priority.factor delete mode 100644 extra/io/windows/process/priority.factor diff --git a/extra/io/priority/priority.factor b/extra/io/priority/priority.factor deleted file mode 100644 index 0790563072..0000000000 --- a/extra/io/priority/priority.factor +++ /dev/null @@ -1,5 +0,0 @@ -USING: io.backend kernel ; -IN: io.priority - -HOOK: get-priority io-backend ( -- n ) -HOOK: set-priority io-backend ( n -- ) diff --git a/extra/io/unix/priority/priority.factor b/extra/io/unix/priority/priority.factor deleted file mode 100644 index deb801e3cf..0000000000 --- a/extra/io/unix/priority/priority.factor +++ /dev/null @@ -1,21 +0,0 @@ -USING: alien.syntax kernel io.priority io.unix.backend -unix ; -IN: io.unix.priority - -: 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 ) ; - -M: unix-io get-priority ( -- n ) - clear_err_no - 0 0 getpriority dup -1 = [ check-errno ] when ; - -M: unix-io set-priority ( n -- ) - 0 0 rot setpriority io-error ; diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index bd58761a5b..d1c0db72f4 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,5 +1,5 @@ USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts -io.unix.launcher io.unix.mmap io.backend io.unix.priority +io.unix.launcher io.unix.mmap io.backend io.unix.process combinators namespaces system vocabs.loader sequences ; "io.unix." os append require diff --git a/extra/io/windows/process/priority.factor b/extra/io/windows/process/priority.factor deleted file mode 100644 index f0ca04fd8a..0000000000 --- a/extra/io/windows/process/priority.factor +++ /dev/null @@ -1,8 +0,0 @@ -USING: kernel ; -IN: io.windows.process - -M: windows-io current-priority ( -- n ) - ; - -M: windows-io set-current-priority ( n -- ) - ; From 99b9ab367bc330969fa055e504da1f2652ac4e70 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Mar 2008 18:02:39 -0500 Subject: [PATCH 156/886] Move priority code to io.launcher --- extra/io/launcher/launcher-docs.factor | 11 +++++++++++ extra/io/launcher/launcher.factor | 9 ++++++++- extra/io/process/process.factor | 17 ----------------- extra/io/unix/launcher/launcher.factor | 19 +++++++++++++++++-- extra/io/unix/process/process.factor | 19 ------------------- extra/io/windows/process/process.factor | 8 -------- extra/unix/process/process.factor | 5 ++++- 7 files changed, 40 insertions(+), 48 deletions(-) delete mode 100644 extra/io/process/process.factor delete mode 100644 extra/io/unix/process/process.factor delete mode 100644 extra/io/windows/process/process.factor diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 7fdd22c8a5..640801234b 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -33,6 +33,17 @@ $nl { "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 } "." } ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 9c7d64934e..ac8dc15661 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -6,7 +6,6 @@ init threads continuations math io.encodings io.streams.duplex io.nonblocking accessors ; IN: io.launcher - TUPLE: process command @@ -19,6 +18,8 @@ stdin stdout stderr +priority + timeout handle status @@ -32,6 +33,12 @@ SYMBOL: +prepend-environment+ SYMBOL: +replace-environment+ SYMBOL: +append-environment+ +SYMBOL: +lowest-priority+ +SYMBOL: +low-priority+ +SYMBOL: +normal-priority+ +SYMBOL: +high-priority+ +SYMBOL: +highest-priority+ + : ( -- process ) process construct-empty H{ } clone >>environment diff --git a/extra/io/process/process.factor b/extra/io/process/process.factor deleted file mode 100644 index 8a7c5b1a11..0000000000 --- a/extra/io/process/process.factor +++ /dev/null @@ -1,17 +0,0 @@ -USING: io.backend kernel ; -IN: io.priority - -SYMBOL: +lowest-priority+ -SYMBOL: +low-priority+ -SYMBOL: +normal-priority+ -SYMBOL: +high-priority+ -SYMBOL: +highest-priority+ - -HOOK: current-priority io-backend ( -- symbol ) -HOOK: set-current-priority io-backend ( symbol -- ) -HOOK: priority-values ( -- assoc ) - -: lookup-priority ( symbol -- n ) - priority-values at ; - -HOOK: get-process-list io-backend ( -- assoc ) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 8ed1c957af..e16ecde6fa 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -16,6 +16,17 @@ USE: unix : 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 } + } at set-priority + ] when* ; + : redirect-fd ( oldfd fd -- ) 2dup = [ 2drop ] [ dupd dup2 io-error close ] if ; @@ -47,11 +58,15 @@ USE: unix : 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-priority setup-redirection dup pass-environment? [ dup get-environment set-os-envs diff --git a/extra/io/unix/process/process.factor b/extra/io/unix/process/process.factor deleted file mode 100644 index 00df6b6f52..0000000000 --- a/extra/io/unix/process/process.factor +++ /dev/null @@ -1,19 +0,0 @@ -USING: alien.syntax kernel io.process io.unix.backend -unix ; -IN: io.unix.process - -M: unix-io current-priority ( -- n ) - clear_err_no - 0 0 getpriority dup -1 = [ check-errno ] when ; - -M: unix-io set-current-priority ( n -- ) - 0 0 rot setpriority io-error ; - -M: unix-io priority-values ( -- assoc ) - { - { +lowest-priority+ 20 } - { +low-priority+ 10 } - { +normal-priority+ 0 } - { +high-priority+ -10 } - { +highest-priority+ -20 } - } ; diff --git a/extra/io/windows/process/process.factor b/extra/io/windows/process/process.factor deleted file mode 100644 index f0ca04fd8a..0000000000 --- a/extra/io/windows/process/process.factor +++ /dev/null @@ -1,8 +0,0 @@ -USING: kernel ; -IN: io.windows.process - -M: windows-io current-priority ( -- n ) - ; - -M: windows-io set-current-priority ( n -- ) - ; diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor index 6fdc8e358b..c9612c4384 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -33,4 +33,7 @@ IN: unix.process fork dup io-error dup zero? -roll swap curry if ; inline : wait-for-pid ( pid -- status ) - 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; \ No newline at end of file + 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; + +: set-priority ( n -- ) + 0 0 rot setpriority io-error ; \ No newline at end of file From 09d8c8eb88b86f6cea48ab68662484d2f625fd85 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Mar 2008 19:47:30 -0500 Subject: [PATCH 157/886] Launcher documentation --- extra/io/launcher/launcher-docs.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 640801234b..0f6ca3a2c9 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -227,6 +227,7 @@ ARTICLE: "io.launcher" "Operating system processes" { $subsection "io.launcher.detached" } { $subsection "io.launcher.environment" } { $subsection "io.launcher.redirection" } +{ $subsection "io.launcher.priority" } { $subsection "io.launcher.timeouts" } ; ABOUT: "io.launcher" From 8d7367674c42eaadb26d3883bb2fca17e52c2dfb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Mar 2008 19:52:21 -0500 Subject: [PATCH 158/886] Class algebra refactoring --- core/bootstrap/image/image.factor | 6 +- core/bootstrap/primitives.factor | 12 +- core/classes/algebra/algebra-docs.factor | 55 ++++ core/classes/algebra/algebra-tests.factor | 201 ++++++++++++++ core/classes/algebra/algebra.factor | 233 ++++++++++++++++ core/classes/classes-docs.factor | 82 +----- core/classes/classes-tests.factor | 85 +----- core/classes/classes.factor | 257 +++--------------- core/generator/registers/registers.factor | 21 +- core/generic/generic-docs.factor | 6 +- core/generic/generic-tests.factor | 4 +- core/generic/generic.factor | 4 +- core/generic/math/math.factor | 8 +- core/generic/standard/standard.factor | 2 +- core/inference/class/class.factor | 11 +- core/optimizer/control/control.factor | 4 +- core/optimizer/inlining/inlining.factor | 10 +- core/optimizer/known-words/known-words.factor | 9 +- core/optimizer/math/math.factor | 7 +- .../pattern-match/pattern-match.factor | 2 +- core/tuples/tuples-tests.factor | 11 +- extra/tools/deploy/shaker/shaker.factor | 8 +- 22 files changed, 593 insertions(+), 445 deletions(-) create mode 100755 core/classes/algebra/algebra-docs.factor create mode 100755 core/classes/algebra/algebra-tests.factor create mode 100755 core/classes/algebra/algebra.factor mode change 100644 => 100755 core/optimizer/pattern-match/pattern-match.factor diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 52a2496755..6aa4b9212d 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -348,8 +348,10 @@ M: curry ' : emit-global ( -- ) [ { - dictionary source-files - typemap builtins class builtins set +init-caches ! Vocabulary for slot accessors "accessors" create-vocab drop @@ -93,11 +97,6 @@ call "vectors.private" } [ create-vocab drop ] each -H{ } clone source-files set -H{ } clone update-map set -H{ } clone class define-builtin-slots ; -H{ } clone typemap set -num-types get f builtins set - ! Forward definitions "object" "kernel" create t "class" set-word-prop "object" "kernel" create union-class "metaclass" set-word-prop diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor new file mode 100755 index 0000000000..c21098916d --- /dev/null +++ b/core/classes/algebra/algebra-docs.factor @@ -0,0 +1,55 @@ +USING: help.markup help.syntax kernel classes ; +IN: classes.algebra + +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 class-types } +{ $subsection flatten-class } +{ $subsection flatten-builtin-class } +{ $subsection class-types } +{ $subsection class-tags } ; + +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: class-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< +{ $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: class-or +{ $values { "class1" class } { "class2" class } { "class" class } } +{ $description "Outputs the smallest anonymous class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ; + +HELP: class-and +{ $values { "class1" class } { "class2" class } { "class" class } } +{ $description "Outputs the largest anonymous class contained in both " { $snippet "class1" } " and " { $snippet "class2" } "." } ; + +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 } "." } ; diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor new file mode 100755 index 0000000000..24a18559fe --- /dev/null +++ b/core/classes/algebra/algebra-tests.factor @@ -0,0 +1,201 @@ +IN: classes.algebra.tests +USING: alien arrays definitions generic assocs hashtables io +kernel math namespaces parser prettyprint sequences strings +tools.test vectors words quotations classes classes.algebra +classes.private classes.union classes.mixin classes.predicate +vectors definitions source-files compiler.units growable +random inference effects ; + +: class= [ class< ] 2keep swap class< and ; + +: class-and* >r class-and r> class= ; + +: class-or* >r class-or r> class= ; + +[ t ] [ object object object class-and* ] unit-test +[ t ] [ fixnum object fixnum class-and* ] unit-test +[ t ] [ object fixnum fixnum class-and* ] unit-test +[ t ] [ fixnum fixnum fixnum class-and* ] unit-test +[ t ] [ fixnum integer fixnum class-and* ] unit-test +[ t ] [ integer fixnum fixnum class-and* ] unit-test + +[ t ] [ vector fixnum null class-and* ] unit-test +[ t ] [ number object number class-and* ] unit-test +[ t ] [ object number number class-and* ] unit-test +[ t ] [ slice reversed null class-and* ] unit-test +[ t ] [ general-t \ f null class-and* ] unit-test +[ t ] [ general-t \ f object class-or* ] unit-test + +TUPLE: first-one ; +TUPLE: second-one ; +UNION: both first-one union-class ; + +[ t ] [ both tuple classes-intersect? ] unit-test +[ t ] [ vector virtual-sequence null class-and* ] unit-test +[ f ] [ vector virtual-sequence classes-intersect? ] unit-test + +[ t ] [ number vector class-or sequence classes-intersect? ] unit-test + +[ f ] [ number vector class-and 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 + +[ t ] [ \ tuple-class \ class class< ] unit-test +[ f ] [ \ class \ tuple-class class< ] unit-test + +TUPLE: delegate-clone ; + +[ 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 + +TUPLE: a1 ; +TUPLE: b1 ; +TUPLE: c1 ; + +UNION: x1 a1 b1 ; +UNION: y1 a1 c1 ; +UNION: z1 b1 c1 ; + +[ f ] [ z1 x1 y1 class-and class< ] unit-test + +[ t ] [ x1 y1 class-and a1 class< ] unit-test + +[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test + +[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class< ] unit-test + +[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class< ] unit-test + +[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test + +[ f ] [ growable hi-tag classes-intersect? ] unit-test + +[ t ] [ + growable tuple sequence class-and class< +] unit-test + +[ t ] [ + growable assoc class-and tuple class< +] unit-test + +[ t ] [ object \ f \ f class-not class-or class< ] unit-test + +[ t ] [ fixnum class-not integer class-and bignum class= ] unit-test + +[ f ] [ integer integer class-not classes-intersect? ] unit-test + +[ t ] [ array number class-not class< ] unit-test + +[ f ] [ bignum number class-not class< ] unit-test + +[ vector ] [ vector class-not class-not ] unit-test + +[ t ] [ fixnum fixnum bignum class-or class< ] unit-test + +[ f ] [ fixnum class-not integer class-and array class< ] unit-test + +[ f ] [ fixnum class-not integer class< ] unit-test + +[ f ] [ number class-not array class< ] unit-test + +[ f ] [ fixnum class-not array class< ] unit-test + +[ t ] [ number class-not integer class-not class< ] unit-test + +[ t ] [ vector array class-not class-and vector class= ] unit-test + +[ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test + +[ f ] [ fixnum class-not integer class< ] unit-test + +[ t ] [ null class-not object class= ] unit-test + +[ t ] [ object class-not null class= ] unit-test + +[ f ] [ object class-not object class= ] unit-test + +[ f ] [ null class-not null class= ] unit-test + +! Test for hangs? +: random-class classes random ; + +: random-op + { + class-and + class-or + class-not + } random ; + +10 [ + [ ] [ + 20 [ drop random-op ] map >quotation + [ infer effect-in [ random-class ] times ] keep + call + drop + ] unit-test +] times + +: random-boolean + { t f } random ; + +: boolean>class + object null ? ; + +: random-boolean-op + { + and + or + not + xor + } random ; + +: class-xor [ class-or ] 2keep class-and class-not class-and ; + +: boolean-op>class-op + { + { and class-and } + { or class-or } + { not class-not } + { xor class-xor } + } at ; + +20 [ + [ t ] [ + 20 [ drop random-boolean-op ] [ ] map-as dup . + [ infer effect-in [ drop random-boolean ] map dup . ] keep + + [ >r [ ] each r> call ] 2keep + + >r [ boolean>class ] each r> [ boolean-op>class-op ] map call object class= + + = + ] unit-test +] times diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor new file mode 100755 index 0000000000..e2206213a6 --- /dev/null +++ b/core/classes/algebra/algebra.factor @@ -0,0 +1,233 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel classes combinators accessors sequences arrays +vectors assocs namespaces words sorting layouts math hashtables +; +IN: classes.algebra + +: 2cache ( key1 key2 assoc quot -- value ) + >r >r 2array r> [ first2 ] r> compose cache ; inline + +DEFER: (class<) + +: class< ( first second -- ? ) + class<-cache get [ (class<) ] 2cache ; + +DEFER: (class-not) + +: class-not ( class -- complement ) + class-not-cache get [ (class-not) ] cache ; + +DEFER: (classes-intersect?) ( first second -- ? ) + +: classes-intersect? ( first second -- ? ) + classes-intersect-cache get [ (classes-intersect?) ] 2cache ; + +DEFER: (class-and) + +: class-and ( first second -- class ) + class-and-cache get [ (class-and) ] 2cache ; + +DEFER: (class-or) + +: class-or ( first second -- class ) + class-or-cache get [ (class-or) ] 2cache ; + +TUPLE: anonymous-union members ; + +C: anonymous-union + +TUPLE: anonymous-intersection members ; + +C: anonymous-intersection + +TUPLE: anonymous-complement class ; + +C: anonymous-complement + +: superclass< ( first second -- ? ) + >r superclass r> class< ; + +: left-union-class< ( first second -- ? ) + >r members r> [ class< ] curry all? ; + +: right-union-class< ( first second -- ? ) + members [ class< ] with contains? ; + +: left-anonymous-union< ( first second -- ? ) + >r members>> r> [ class< ] curry all? ; + +: right-anonymous-union< ( first second -- ? ) + members>> [ class< ] with contains? ; + +: left-anonymous-intersection< ( first second -- ? ) + >r members>> r> [ class< ] curry contains? ; + +: right-anonymous-intersection< ( first second -- ? ) + members>> [ class< ] with all? ; + +: anonymous-complement< ( first second -- ? ) + [ class>> ] 2apply swap class< ; + +: (class<) ( first second -- -1/0/1 ) + { + { [ 2dup eq? ] [ 2drop t ] } + { [ dup object eq? ] [ 2drop t ] } + { [ over null eq? ] [ 2drop t ] } + { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] } + { [ over anonymous-union? ] [ left-anonymous-union< ] } + { [ over anonymous-intersection? ] [ left-anonymous-intersection< ] } + { [ over anonymous-complement? ] [ 2drop f ] } + { [ over members ] [ left-union-class< ] } + { [ dup anonymous-union? ] [ right-anonymous-union< ] } + { [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] } + { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } + { [ dup members ] [ right-union-class< ] } + { [ over superclass ] [ superclass< ] } + { [ t ] [ 2drop f ] } + } cond ; + +: anonymous-union-intersect? ( first second -- ? ) + members>> [ classes-intersect? ] with contains? ; + +: anonymous-intersection-intersect? ( first second -- ? ) + members>> [ classes-intersect? ] with all? ; + +: anonymous-complement-intersect? ( first second -- ? ) + class>> class< not ; + +: union-class-intersect? ( first second -- ? ) + members [ classes-intersect? ] with contains? ; + +: tuple-class-intersect? ( first second -- ? ) + { + { [ over tuple eq? ] [ 2drop t ] } + { [ over builtin-class? ] [ 2drop f ] } + { [ over tuple-class? ] [ [ class< ] 2keep swap class< or ] } + { [ t ] [ swap classes-intersect? ] } + } cond ; + +: builtin-class-intersect? ( first second -- ? ) + { + { [ 2dup eq? ] [ 2drop t ] } + { [ over builtin-class? ] [ 2drop f ] } + { [ t ] [ swap classes-intersect? ] } + } cond ; + +: (classes-intersect?) ( first second -- ? ) + { + { [ dup anonymous-union? ] [ anonymous-union-intersect? ] } + { [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] } + { [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] } + { [ dup tuple-class? ] [ tuple-class-intersect? ] } + { [ dup builtin-class? ] [ builtin-class-intersect? ] } + { [ dup superclass ] [ superclass classes-intersect? ] } + { [ dup members ] [ union-class-intersect? ] } + } cond ; + +: left-union-and ( first second -- class ) + >r members r> [ class-and ] curry map ; + +: right-union-and ( first second -- class ) + members [ class-and ] with map ; + +: left-anonymous-union-and ( first second -- class ) + >r members>> r> [ class-and ] curry map ; + +: right-anonymous-union-and ( first second -- class ) + members>> [ class-and ] with map ; + +: left-anonymous-intersection-and ( first second -- class ) + >r members>> r> add ; + +: right-anonymous-intersection-and ( first second -- class ) + members>> swap add ; + +: (class-and) ( first second -- class ) + { + { [ 2dup class< ] [ drop ] } + { [ 2dup swap class< ] [ nip ] } + { [ 2dup classes-intersect? not ] [ 2drop null ] } + { [ dup members ] [ right-union-and ] } + { [ dup anonymous-union? ] [ right-anonymous-union-and ] } + { [ dup anonymous-intersection? ] [ right-anonymous-intersection-and ] } + { [ over members ] [ left-union-and ] } + { [ over anonymous-union? ] [ left-anonymous-union-and ] } + { [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] } + { [ t ] [ 2array ] } + } cond ; + +: left-anonymous-union-or ( first second -- class ) + >r members>> r> add ; + +: right-anonymous-union-or ( first second -- class ) + members>> swap add ; + +: (class-or) ( first second -- class ) + { + { [ 2dup class< ] [ nip ] } + { [ 2dup swap class< ] [ drop ] } + { [ dup anonymous-union? ] [ right-anonymous-union-or ] } + { [ over anonymous-union? ] [ left-anonymous-union-or ] } + { [ t ] [ 2array ] } + } cond ; + +: (class-not) ( class -- complement ) + { + { [ dup anonymous-complement? ] [ class>> ] } + { [ dup object eq? ] [ drop null ] } + { [ dup null eq? ] [ drop object ] } + { [ t ] [ ] } + } cond ; + +: largest-class ( seq -- n elt ) + dup [ + [ 2dup class< >r swap class< not r> and ] + with subset empty? + ] curry find [ "Topological sort failed" throw ] unless* ; + +: sort-classes ( seq -- newseq ) + >vector + [ dup empty? not ] + [ dup largest-class >r over delete-nth r> ] + [ ] unfold nip ; + +: min-class ( class seq -- class/f ) + [ dupd classes-intersect? ] subset dup empty? [ + 2drop f + ] [ + tuck [ class< ] with all? [ peek ] [ drop f ] if + ] if ; + +: (flatten-class) ( class -- ) + { + { [ dup tuple-class? ] [ dup set ] } + { [ dup builtin-class? ] [ dup set ] } + { [ dup members ] [ members [ (flatten-class) ] each ] } + { [ dup superclass ] [ superclass (flatten-class) ] } + { [ t ] [ drop ] } + } 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 -- assoc ) + flatten-class [ + dup tuple class< [ 2drop tuple tuple ] when + ] assoc-map ; + +: class-types ( class -- seq ) + flatten-builtin-class keys + [ "type" word-prop ] map natural-sort ; + +: class-tags ( class -- tag/f ) + class-types [ + dup num-tags get >= + [ drop object tag-number ] when + ] map prune ; diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 1e71173153..9573de8949 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -12,21 +12,6 @@ $nl { $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 @@ -93,15 +78,9 @@ 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: classclass ( n -- class ) builtins get-global nth ; @@ -37,146 +54,12 @@ PREDICATE: word predicate "predicating" word-prop >boolean ; r> predicate-effect define-declared ; : superclass ( class -- super ) - "superclass" word-prop ; + #! Output f for non-classes to work with algebra code + dup class? [ "superclass" word-prop ] [ drop f ] if ; -: 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) ] } - { [ t ] [ drop ] } - } 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 classr 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 ; - -: lookup-tuple-union ( classes -- class ) - class-map 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 ; - -: class-or-fixup ( set set -- set ) - union - tuple over key? - [ [ drop tuple-class? not ] assoc-subset ] when ; - -: (class-or) ( class class -- class ) - [ flatten-class ] 2apply class-or-fixup lookup-tuple-union ; - -: (class-and) ( class class -- class ) - 2dup [ tuple swap class< ] either? [ - [ flatten-builtin-class ] 2apply - intersect lookup-union - ] [ - [ flatten-class ] 2apply - intersect lookup-tuple-union - ] if ; - -: 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 ; - -: class-and ( class1 class2 -- class ) - { - { [ 2dup class< ] [ drop ] } - { [ 2dup swap class< ] [ nip ] } - { [ 2dup [ tuple-class? ] both? ] [ tuple-class-and ] } - { [ t ] [ (class-and) ] } - } cond ; - -: 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 -- ) @@ -184,36 +67,9 @@ M: word reset-class drop ; assoc ] keep - classr >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-map -: class-map+ ( class -- ) - dup flatten-class class-map get push-at ; - -: class-map- ( class -- ) - dup flatten-class class-map get pop-at ; - -! Class definition -: cache-class ( class -- ) - dup typemap+ dup class-map+ dup class : define-class-props ( members superclass metaclass -- assoc ) @@ -293,14 +108,12 @@ GENERIC: update-methods ( assoc -- ) : define-class ( word members superclass metaclass -- ) #! If it was already a class, update methods after. + reset-caches 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 ; + over update-map- + dupd (define-class) + dup update-map+ + class-usages dup update-predicates update-methods ; GENERIC: class ( object -- class ) inline diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index 307e3a99f1..e03923e860 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -1,9 +1,9 @@ ! 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 ; IN: generator.registers SYMBOL: +input+ @@ -581,13 +581,14 @@ M: loc lazy-store 2drop t ] if ; +: class-tags ( class -- tag/f ) + class-types [ + dup num-tags get >= + [ drop object tag-number ] when + ] map prune ; + : 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 -- ? ) { diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index b59c92c798..56de801e7a 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -1,6 +1,6 @@ -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" diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 785600cfb0..853a03d184 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -1,8 +1,8 @@ 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 ) diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 8fe5e4921a..36ca0358b7 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -2,7 +2,7 @@ ! 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 @@ -138,7 +138,7 @@ M: method-body forget* M: class forget* ( class -- ) dup forget-methods - dup uncache-class + dup update-map- forget-word ; M: assoc update-methods ( assoc -- ) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 46f57a1629..93c89af25c 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -1,8 +1,8 @@ -! 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.algebra definitions ; IN: generic.math PREDICATE: class math-class ( object -- ? ) @@ -16,8 +16,8 @@ PREDICATE: class math-class ( object -- ? ) : math-precedence ( class -- n ) { - { [ dup class-empty? ] [ drop { -1 -1 } ] } - { [ dup math-class? ] [ types last/first ] } + { [ dup null class< ] [ drop { -1 -1 } ] } + { [ dup math-class? ] [ class-types last/first ] } { [ t ] [ drop { 100 100 } ] } } cond ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 37f72e7d95..4105a05cb1 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -3,7 +3,7 @@ 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 ; IN: generic.standard TUPLE: standard-combination # ; diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 690571de98..7764fd4fd1 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -2,8 +2,8 @@ ! 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 ; IN: inference.class ! Class inference @@ -88,8 +88,11 @@ M: interval-constraint apply-constraint swap interval-constraint-value intersect-value-interval ; : set-class-interval ( class value -- ) - >r "interval" word-prop dup - [ r> set-value-interval* ] [ r> 2drop ] if ; + over class? [ + over "interval" word-prop [ + >r "interval" word-prop r> set-value-interval* + ] [ 2drop ] if + ] [ 2drop ] if ; : value-class* ( value -- class ) value-classes get at object or ; diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index b04d4677ce..c108e3b1a7 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -3,8 +3,8 @@ 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 diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 04d7ab4ee5..1f3df92421 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -3,10 +3,10 @@ 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 optimizer.specializers -optimizer.def-use optimizer.pattern-match generic.standard -optimizer.control kernel.private ; +combinators classes classes.algebra generic.math continuations +optimizer.def-use optimizer.backend generic.standard +optimizer.specializers optimizer.def-use optimizer.pattern-match +generic.standard optimizer.control kernel.private ; IN: optimizer.inlining : remember-inlining ( node history -- ) @@ -175,7 +175,7 @@ DEFER: (flat-length) : 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 ; diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 18c98c5115..0a3442566c 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -7,8 +7,9 @@ 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 ; +classes.algebra optimizer.def-use optimizer.backend +optimizer.pattern-match optimizer.inlining float-arrays +sequences.private combinators ; ! the output of and has the class which is ! its second-to-last input @@ -89,10 +90,10 @@ optimizer.inlining float-arrays sequences.private combinators ; ! type applied to an object of a known type can be folded : known-type? ( node -- ? ) - node-class-first types length 1 number= ; + node-class-first class-types length 1 number= ; : fold-known-type ( node -- node ) - dup node-class-first types inline-literals ; + dup node-class-first class-types inline-literals ; \ type [ { [ dup known-type? ] [ fold-known-type ] } diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 7afc177d10..349cf88f17 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -5,9 +5,10 @@ USING: alien alien.accessors arrays generic hashtables kernel 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 +generic.standard system ; { + bignum+ float+ fixnum+fast } { { { number 0 } [ drop ] } diff --git a/core/optimizer/pattern-match/pattern-match.factor b/core/optimizer/pattern-match/pattern-match.factor old mode 100644 new mode 100755 index ed78330492..0e7e801938 --- a/core/optimizer/pattern-match/pattern-match.factor +++ b/core/optimizer/pattern-match/pattern-match.factor @@ -2,7 +2,7 @@ ! 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: @ diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index b5076ea22b..fec3bdbc6f 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -5,9 +5,6 @@ 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 construct-boa ; @@ -90,12 +87,6 @@ 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 @@ -121,7 +112,7 @@ TUPLE: yo-momma ; [ [ t ] [ \ yo-momma class? ] unit-test [ ] [ \ yo-momma forget ] unit-test - [ f ] [ \ yo-momma typemap get values memq? ] unit-test + [ f ] [ \ yo-momma update-map get values memq? ] unit-test [ f ] [ \ yo-momma crossref get at ] unit-test ] with-compilation-unit diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 76e4a212b2..754d93d9b4 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -148,8 +148,12 @@ IN: tools.deploy.shaker layouts:tag-mask layouts:tag-numbers layouts:type-numbers - classes:typemap - classes:class-map + classes:class<-cache + classes:class-not-cache + classes:classes-intersect-cache + classes:class-and-cache + classes:class-or-cache + classes:update-map vocab-roots definitions:crossref compiled-crossref From 577c670631086600ea675467195325438fe1e2b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Mar 2008 20:15:42 -0500 Subject: [PATCH 159/886] Test fix --- core/optimizer/optimizer-tests.factor | 5 ++-- extra/tools/deploy/shaker/shaker.factor | 36 ++++++++++++------------- 2 files changed, 20 insertions(+), 21 deletions(-) diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 3abccecc7f..89cea45aee 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -1,8 +1,9 @@ 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 ; +optimizer.backend classes classes.algebra inference.dataflow +tuples.private continuations growable optimizer.inlining +namespaces hints ; IN: optimizer.tests [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 754d93d9b4..f731f5d694 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -139,31 +139,29 @@ IN: tools.deploy.shaker { } { "cpu" } strip-vocab-globals % { - vocabs:dictionary - lexer-factory - vocabs:load-vocab-hook - root-cache + classes:class-and-cache + classes:class-not-cache + classes:class-or-cache + classes:class<-cache + classes:classes-intersect-cache + classes:update-map + compiled-crossref + compiler.units:recompile-hook + definitions:crossref + interactive-vocabs layouts:num-tags layouts:num-types layouts:tag-mask layouts:tag-numbers layouts:type-numbers - classes:class<-cache - classes:class-not-cache - classes:classes-intersect-cache - classes:class-and-cache - classes:class-or-cache - classes:update-map - vocab-roots - definitions:crossref - compiled-crossref - interactive-vocabs - word - compiler.units:recompile-hook - listener:listener-hook lexer-factory - classes:update-map - classes:class Date: Mon, 24 Mar 2008 20:44:39 -0500 Subject: [PATCH 160/886] Fix --- extra/io/unix/unix.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index d1c0db72f4..0a7fc72662 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,5 +1,5 @@ USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts -io.unix.launcher io.unix.mmap io.backend io.unix.process -combinators namespaces system vocabs.loader sequences ; +io.unix.launcher io.unix.mmap io.backend combinators namespaces +system vocabs.loader sequences ; "io.unix." os append require From 1c75abce235a4062b1ef4f66db53af97b5a19fa3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 25 Mar 2008 04:40:36 -0600 Subject: [PATCH 161/886] lsys.ui: Add a '500 sleep' workaround --- extra/lsys/ui/ui.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/lsys/ui/ui.factor b/extra/lsys/ui/ui.factor index 45372aec6c..c8d103a084 100644 --- a/extra/lsys/ui/ui.factor +++ b/extra/lsys/ui/ui.factor @@ -196,6 +196,8 @@ slate> handler> set-gadget-delegate handler> "L-system view" open-window +500 sleep + slate> find-gl-context 1 glGenLists >model From 8362ef09588d883934f66cb6a4febdb00f55a49e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 25 Mar 2008 13:51:09 -0500 Subject: [PATCH 162/886] fix netbsd32 --- misc/factor.sh | 2 ++ 1 file changed, 2 insertions(+) diff --git a/misc/factor.sh b/misc/factor.sh index 9d4f26fa46..a1437c67bf 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -90,6 +90,8 @@ set_gcc() { 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 From dc22e5767b0d655847e0a9312c5817b15348629e Mon Sep 17 00:00:00 2001 From: "U-FROGGER\\erg" Date: Tue, 25 Mar 2008 14:37:17 -0500 Subject: [PATCH 163/886] add more dlls to factor.sh --- misc/factor.sh | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/misc/factor.sh b/misc/factor.sh index 9d4f26fa46..5fc8654216 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -346,10 +346,25 @@ maybe_download_dlls() { 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 - get_url http://factorcode.org/dlls/sqlite3.dll chmod 777 *.dll check_ret chmod fi @@ -433,6 +448,7 @@ case "$1" in 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 ;; *) usage ;; esac From b13e0f7042f38814ed28166e6d11ad97b488089c Mon Sep 17 00:00:00 2001 From: erg Date: Tue, 25 Mar 2008 19:50:39 -0500 Subject: [PATCH 164/886] redo path handling --- core/io/files/files-tests.factor | 51 +++++++++ core/io/files/files.factor | 152 ++++++++++++++++--------- extra/io/unix/files/files-tests.factor | 6 + 3 files changed, 155 insertions(+), 54 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 4cda463983..e3765fead0 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -9,6 +9,9 @@ io.files.unique sequences strings accessors ; [ "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 +[ "/" ] [ "/" file-name ] unit-test +[ "///" ] [ "///" file-name ] unit-test [ ] [ { "Hello world." } @@ -144,3 +147,51 @@ io.files.unique sequences strings accessors ; ] 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 +[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test +[ "/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 +[ "/lib" ] [ "/" "../lib" append-path ] unit-test +[ "/lib/" ] [ "/" "../lib/" append-path ] unit-test + +[ "" ] [ "" "." append-path ] unit-test +[ "" ".." append-path ] must-fail + +[ "/" ] [ "/" "./." append-path ] unit-test +[ "/" ] [ "/" "././" append-path ] unit-test +[ "/" ] [ "/" "../.." append-path ] unit-test +[ "/" ] [ "/" "../../" append-path ] unit-test +[ "/lib" ] [ "/" "../../lib" append-path ] unit-test +[ "/lib/" ] [ "/" "../../lib/" 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 + +[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test +[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test + +[ "foo/" ] [ "foo/bar/." parent-directory ] unit-test +[ "foo/" ] [ "foo/bar/./" parent-directory ] unit-test +[ "foo/" ] [ "foo/bar/baz/.." parent-directory ] unit-test +[ "foo/" ] [ "foo/bar/baz/../" parent-directory ] unit-test + +[ "." 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 + +[ "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 diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 21cc7c8f0a..8595f227bf 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -3,7 +3,7 @@ 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 ; IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) @@ -21,7 +21,26 @@ HOOK: (file-appender) io-backend ( path -- stream ) : ( path encoding -- stream ) swap (file-appender) swap ; -HOOK: rename-file io-backend ( from to -- ) +: file-lines ( path encoding -- seq ) + lines ; + +: with-file-reader ( path encoding quot -- ) + >r r> with-stream ; inline + +: file-contents ( path encoding -- str ) + contents ; + +: with-file-writer ( path encoding quot -- ) + >r 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 r> with-stream ; inline ! Pathnames : path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ; @@ -32,42 +51,84 @@ HOOK: rename-file io-backend ( from to -- ) : left-trim-separators ( str -- newstr ) [ path-separator? ] left-trim ; -: append-path ( str1 str2 -- str ) - >r right-trim-separators "/" r> - left-trim-separators 3append ; - -: prepend-path ( str1 str2 -- str ) - swap append-path ; inline - : 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? ; - -: special-directory? ( name -- ? ) { "." ".." } member? ; +M: object root-directory? ( path -- ? ) + dup empty? [ drop f ] [ [ path-separator? ] all? ] if ; ERROR: no-parent-directory path ; : parent-directory ( path -- parent ) - right-trim-separators { - { [ dup empty? ] [ drop "/" ] } - { [ dup root-directory? ] [ ] } - { [ dup [ path-separator? ] contains? not ] [ drop "." ] } + dup root-directory? [ + right-trim-separators + dup last-path-separator [ + 1+ cut + { + { "." [ 1 head* parent-directory ] } + { ".." [ + 2 head* parent-directory parent-directory + ] } + [ drop ] + } case + ] [ no-parent-directory ] if + ] unless ; + + + +: absolute-path? ( path -- ? ) + dup empty? [ drop f ] [ first path-separator? ] if ; + +: 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 + ] } { [ t ] [ - dup last-path-separator drop 1+ cut - special-directory? [ no-parent-directory ] when + >r right-trim-separators "/" r> + left-trim-separators 3append ] } } cond ; -: file-name ( path -- string ) - right-trim-separators { - { [ dup empty? ] [ drop "/" ] } - { [ dup last-path-separator ] [ 1+ tail ] } - { [ t ] [ drop ] } - } cond ; +: prepend-path ( str1 str2 -- str ) + swap append-path ; inline +: file-name ( path -- string ) + 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 ) @@ -94,8 +155,12 @@ HOOK: cd io-backend ( path -- ) HOOK: cwd io-backend ( -- path ) +SYMBOL: current-directory + +[ cwd current-directory set-global ] "current-directory" add-init-hook + : with-directory ( path quot -- ) - cwd [ cd ] curry rot cd [ ] cleanup ; inline + current-directory swap with-variable ; inline ! Creating directories HOOK: make-directory io-backend ( path -- ) @@ -118,7 +183,7 @@ HOOK: make-directory io-backend ( path -- ) dup string? [ 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 ; @@ -199,34 +264,6 @@ DEFER: copy-tree-into : resource-exists? ( path -- ? ) ?resource-path exists? ; -! Pathname presentations -TUPLE: pathname string ; - -C: pathname - -M: pathname <=> [ pathname-string ] compare ; - -: file-lines ( path encoding -- seq ) - lines ; - -: with-file-reader ( path encoding quot -- ) - >r r> with-stream ; inline - -: file-contents ( path encoding -- str ) - contents ; - -: with-file-writer ( path encoding quot -- ) - >r 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 r> with-stream ; inline - : temp-directory ( -- path ) "temp" resource-path dup exists? not @@ -235,6 +272,13 @@ M: pathname <=> [ pathname-string ] compare ; : temp-file ( name -- path ) temp-directory prepend-path ; +! Pathname presentations +TUPLE: pathname string ; + +C: pathname + +M: pathname <=> [ pathname-string ] compare ; + ! Home directory : home ( -- dir ) { diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor index f5366d32ae..98de09e8f1 100755 --- a/extra/io/unix/files/files-tests.factor +++ b/extra/io/unix/files/files-tests.factor @@ -6,3 +6,9 @@ IN: io.unix.files.tests [ "/" ] [ "/etc/" parent-directory ] unit-test [ "/" ] [ "/etc" parent-directory ] unit-test [ "/" ] [ "/" parent-directory ] unit-test +[ "asdf" parent-directory ] must-fail + +[ f ] [ "" root-directory? ] unit-test +[ t ] [ "/" root-directory? ] unit-test +[ t ] [ "//" root-directory? ] unit-test +[ t ] [ "///////" root-directory? ] unit-test From 807c84918b952c377e949454fc13b59dfbeeb93b Mon Sep 17 00:00:00 2001 From: erg Date: Tue, 25 Mar 2008 19:52:07 -0500 Subject: [PATCH 165/886] minor cleanup in windows path handling --- extra/io/windows/nt/files/files.factor | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 7cf056674f..540737004b 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -2,7 +2,8 @@ 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 ; +sequences.lib ascii splitting alien strings assocs +combinators.cleave ; IN: io.windows.nt.files M: windows-nt-io cwd @@ -18,18 +19,19 @@ M: windows-nt-io cd M: windows-nt-io root-directory? ( path -- ? ) dup length 2 = [ - dup first Letter? - swap second CHAR: : = and + first2 + [ Letter? ] [ CHAR: : = ] bi* and ] [ drop f ] if ; +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 prepend ; @@ -58,9 +60,12 @@ M: windows-nt-io root-directory? ( path -- ? ) ] } } cond ; +ERROR: nonstring-pathname ; +ERROR: empty-pathname ; + M: windows-nt-io normalize-pathname ( string -- string ) - dup string? [ "Pathname must be a string" throw ] unless - dup empty? [ "Empty pathname" throw ] when + dup string? [ nonstring-pathname ] unless + dup empty? [ empty-pathname ] when { { CHAR: / CHAR: \\ } } substitute cwd swap windows-append-path [ "/\\." member? ] right-trim From 06848c8e7575983cb590beb7c1ad43ed1dfdf66f Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 25 Mar 2008 21:17:37 -0400 Subject: [PATCH 166/886] UTF-16 native order; better encodings docs --- core/io/encodings/binary/binary-docs.factor | 5 +- core/io/encodings/encodings-docs.factor | 29 ++++++----- core/io/encodings/utf8/utf8-docs.factor | 11 ++-- extra/help/handbook/handbook.factor | 13 ++++- extra/io/encodings/8-bit/8-bit-docs.factor | 57 ++++++++++++++------- extra/io/encodings/ascii/ascii-docs.factor | 8 +++ extra/io/encodings/utf16/utf16-docs.factor | 19 ++++--- extra/io/encodings/utf16/utf16-tests.factor | 10 +++- extra/io/encodings/utf16/utf16.factor | 14 ++++- 9 files changed, 115 insertions(+), 51 deletions(-) create mode 100644 extra/io/encodings/ascii/ascii-docs.factor diff --git a/core/io/encodings/binary/binary-docs.factor b/core/io/encodings/binary/binary-docs.factor index 823eea67be..fdd9828867 100644 --- a/core/io/encodings/binary/binary-docs.factor +++ b/core/io/encodings/binary/binary-docs.factor @@ -2,4 +2,7 @@ USING: help.syntax help.markup ; 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 diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index 0f43bba0db..07e0f9f401 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -1,16 +1,16 @@ 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" -"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." +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 } { $subsection } { $subsection } ; @@ -38,19 +38,22 @@ HELP: 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:" -{ $vocab-subsection "io.encodings.utf8" } -{ $vocab-subsection "io.encodings.ascii" } -{ $vocab-subsection "io.encodings.8-bit" } -{ $vocab-subsection "io.encodings.binary" } -{ $vocab-subsection "io.encodings.utf16" } ; +{ $vocab-subsection "ASCII" "io.encodings.ascii" } +{ $vocab-subsection "Binary" "io.encodings.binary" } +{ $vocab-subsection "Strict encodings" "io.encodings.strict" } +{ $vocab-subsection "8-bit encodings" "io.encodings.8-bit" } +{ $vocab-subsection "UTF-8" "io.encodings.utf8" } +{ $vocab-subsection "UTF-16" "io.encodings.utf16" } +{ $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." +"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 } +{ $subsection } +"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 } -"Optionally, an encoding can override the constructor words:" -{ $subsection } -{ $subsection } ; +{ $see-also "encodings-introduction" } ; HELP: decode-char { $values { "stream" "an underlying input stream" } diff --git a/core/io/encodings/utf8/utf8-docs.factor b/core/io/encodings/utf8/utf8-docs.factor index dbbc193a02..7a29039eca 100755 --- a/core/io/encodings/utf8/utf8-docs.factor +++ b/core/io/encodings/utf8/utf8-docs.factor @@ -1,11 +1,8 @@ -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 diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 1310b58133..4079386d7f 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -170,7 +170,17 @@ ARTICLE: "collections" "Collections" { $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.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 "\"filename\" utf8 " } +"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 "\"filename\" utf8 strict " } ; ARTICLE: "io" "Input and output" { $heading "Streams" } @@ -188,6 +198,7 @@ ARTICLE: "io" "Input and output" { $subsection "io.mmap" } { $subsection "io.monitors" } { $heading "Encodings" } +{ $subsection "encodings-introduction" } { $subsection "io.encodings" } { $subsection "io.encodings.string" } { $heading "Other features" } diff --git a/extra/io/encodings/8-bit/8-bit-docs.factor b/extra/io/encodings/8-bit/8-bit-docs.factor index ff21094ba1..8e5fd815bc 100644 --- a/extra/io/encodings/8-bit/8-bit-docs.factor +++ b/extra/io/encodings/8-bit/8-bit-docs.factor @@ -34,58 +34,77 @@ HELP: define-8-bit-encoding { $description "Creates a new encoding with the given name, using the resource file at the path to tell how to encode and decode octets. The resource file should be in a similar format to those at 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." } ; +{ $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." } ; +{ $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." } ; +{ $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." } ; +{ $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." } ; +{ $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." } ; +{ $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." } ; +{ $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." } ; +{ $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." } ; +{ $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." } ; +{ $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." } ; +{ $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." } ; +{ $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." } ; +{ $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." } ; +{ $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." } ; +{ $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." } ; +{ $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." } ; +{ $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." } ; +{ $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." } ; +{ $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" } ; diff --git a/extra/io/encodings/ascii/ascii-docs.factor b/extra/io/encodings/ascii/ascii-docs.factor new file mode 100644 index 0000000000..0b54a341d9 --- /dev/null +++ b/extra/io/encodings/ascii/ascii-docs.factor @@ -0,0 +1,8 @@ +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 diff --git a/extra/io/encodings/utf16/utf16-docs.factor b/extra/io/encodings/utf16/utf16-docs.factor index 018a15a534..7198cb2b27 100644 --- a/extra/io/encodings/utf16/utf16-docs.factor +++ b/extra/io/encodings/utf16/utf16-docs.factor @@ -1,22 +1,25 @@ USING: help.markup help.syntax io.encodings strings ; IN: io.encodings.utf16 -ARTICLE: "utf16" "Working with UTF-16-encoded data" +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 } -{ $subsection utf16 } -"All of these conform to the " { $link "encodings-protocol" } "." ; +{ $subsection utf16n } ; -ABOUT: "utf16" +ABOUT: "io.encodings.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." } ; +{ $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." } ; 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." } ; +{ $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." } ; 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." } ; +{ $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." } ; -{ utf16 utf16le utf16be } related-words +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 in of wide_t*." } ; + +{ utf16 utf16le utf16be utf16n } related-words diff --git a/extra/io/encodings/utf16/utf16-tests.factor b/extra/io/encodings/utf16/utf16-tests.factor index 89b61a3e37..6985983917 100755 --- a/extra/io/encodings/utf16/utf16-tests.factor +++ b/extra/io/encodings/utf16/utf16-tests.factor @@ -1,5 +1,7 @@ USING: kernel tools.test io.encodings.utf16 arrays sbufs -sequences io.encodings io unicode io.encodings.string ; +io.streams.byte-array sequences io.encodings io unicode +io.encodings.string alien.c-types 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 @@ -20,3 +22,9 @@ sequences io.encodings io unicode io.encodings.string ; [ { 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 correct-endian ] unit-test +[ t ] [ utf16n correct-endian ] unit-test diff --git a/extra/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor index 290761ec91..e8ca04af35 100755 --- a/extra/io/encodings/utf16/utf16.factor +++ b/extra/io/encodings/utf16/utf16.factor @@ -1,7 +1,8 @@ ! 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 ; +io.encodings combinators splitting io byte-arrays inspector +alien.c-types ; IN: io.encodings.utf16 TUPLE: utf16be ; @@ -10,6 +11,8 @@ TUPLE: utf16le ; TUPLE: utf16 ; +TUPLE: utf16n ; + ( stream utf16 -- decoder ) M: utf16 ( stream utf16 -- encoder ) drop bom-le over stream-write utf16le ; +! Native-order UTF-16 + +: native-utf16 ( -- descriptor ) + little-endian? utf16le utf16be ? ; + +M: utf16n drop native-utf16 ; + +M: utf16n drop native-utf16 ; + PRIVATE> From c9b22c92a67fd50177378e5566f0e55a3cba9715 Mon Sep 17 00:00:00 2001 From: erg Date: Tue, 25 Mar 2008 21:09:39 -0500 Subject: [PATCH 167/886] redo target --- build-support/target | 70 ++++++++++++++++++++++---------------------- 1 file changed, 35 insertions(+), 35 deletions(-) diff --git a/build-support/target b/build-support/target index 1903a6da64..1fbfb31d11 100755 --- a/build-support/target +++ b/build-support/target @@ -1,38 +1,38 @@ #!/bin/sh -if [ \( `uname -s ` = FreeBSD \) -a \( `uname -p` = i386 \) ] -then - echo freebsd-x86-32 -elif [ \( `uname -s` = FreeBSD \) -a \( `uname -m` = amd64 \) ] -then - echo freebsd-x86-64 -elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = i386 \) ] -then - echo openbsd-x86-32 -elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = amd64 \) ] -then - echo openbsd-x86-64 -elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = i386 \) ] -then - echo netbsd-x86-32 -elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = x86_64 \) ] -then - echo netbsd-x86-64 -elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ] -then - echo macosx-ppc -elif [ `uname -s` = Darwin ] -then - echo macosx-x86-`./build-support/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-`./build-support/wordsize` -else - echo help +uname_s=`uname -s` +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 + +uname_m=`uname -m` +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 + +WORD=`./build-support/wordsize` + +MAKE_TARGET=$OS-$ARCH-$WORD +if [[ $OS == macosx && $ARCH == ppc ]] ; then + MAKE_TARGET=$OS-$ARCH fi +if [[ $OS == linux && $ARCH == ppc ]] ; then + MAKE_TARGET=$OS-$ARCH +fi + +echo $MAKE_TARGET From 9b7246555a8107262dc7e674d845ff3ac0d48300 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 26 Mar 2008 15:26:54 +1300 Subject: [PATCH 168/886] Fix just parser in pegs --- extra/peg/parsers/parsers-tests.factor | 4 ++++ extra/peg/parsers/parsers.factor | 4 ++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/peg/parsers/parsers-tests.factor b/extra/peg/parsers/parsers-tests.factor index 08bde98419..e80baf3c4f 100644 --- a/extra/peg/parsers/parsers-tests.factor +++ b/extra/peg/parsers/parsers-tests.factor @@ -48,3 +48,7 @@ IN: peg.parsers.tests [ 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 diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 4bba60bb09..13509e81f7 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -3,14 +3,14 @@ USING: kernel sequences strings namespaces math assocs shuffle vectors arrays combinators.lib math.parser match unicode.categories sequences.deep peg peg.private - peg.search math.ranges ; + peg.search math.ranges words ; IN: peg.parsers TUPLE: just-parser p1 ; : just-pattern [ - dup [ + execute dup [ dup parse-result-remaining empty? [ drop f ] unless ] when ] ; From b1561de0f6636af53f2e53918b9f4e60265ad076 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 26 Mar 2008 15:40:17 +1300 Subject: [PATCH 169/886] Reduce amount of generated code for peg token parser --- extra/peg/peg.factor | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 1707193e70..ae5ed2f8b2 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -43,17 +43,16 @@ TUPLE: token-parser symbol ; MATCH-VARS: ?token ; -: token-pattern ( -- quot ) - [ - ?token 2dup head? [ - dup >r length tail-slice r> - ] [ - 2drop f - ] if - ] ; - +: parse-token ( input string -- result ) + #! Parse the string, returning a parse result + 2dup head? [ + dup >r length tail-slice r> + ] [ + 2drop f + ] if ; + M: token-parser (compile) ( parser -- quot ) - token-parser-symbol \ ?token token-pattern match-replace ; + token-parser-symbol [ parse-token ] curry ; TUPLE: satisfy-parser quot ; From 2bc882bf5aabb65198a798fb645c65c90bceacf0 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 25 Mar 2008 22:45:26 -0400 Subject: [PATCH 170/886] XML reports its encoding as UTF-8 --- extra/xml/tests/errors.factor | 2 +- extra/xml/tests/templating.factor | 2 +- extra/xml/tests/test.factor | 6 +++--- extra/xml/tokenize/tokenize.factor | 2 +- extra/xml/utilities/utilities.factor | 2 +- extra/xml/xml.factor | 2 +- 6 files changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/xml/tests/errors.factor b/extra/xml/tests/errors.factor index b421ae011a..6ba0b0d560 100755 --- a/extra/xml/tests/errors.factor +++ b/extra/xml/tests/errors.factor @@ -16,7 +16,7 @@ T{ extra-attrs T{ parsing-error f 1 32 } V{ T{ name f "" "foo" f } } T{ bad-version T{ parsing-error f 1 28 } "5 million" } "" xml-error-test T{ notags f } "" xml-error-test T{ multitags f } "" 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 } } "" xml-error-test T{ capitalized-prolog T{ parsing-error f 1 6 } "XmL" } "" xml-error-test diff --git a/extra/xml/tests/templating.factor b/extra/xml/tests/templating.factor index 6db98ec848..d81e807fe5 100644 --- a/extra/xml/tests/templating.factor +++ b/extra/xml/tests/templating.factor @@ -40,4 +40,4 @@ M: object (r-ref) drop ; sample-doc string>xml dup template xml>string ] with-scope ; -[ "foo
blah

" ] [ test-refs ] unit-test +[ "foo

" ] [ test-refs ] unit-test diff --git a/extra/xml/tests/test.factor b/extra/xml/tests/test.factor index 02c7aecb13..98146136e6 100644 --- a/extra/xml/tests/test.factor +++ b/extra/xml/tests/test.factor @@ -26,7 +26,7 @@ SYMBOL: xml-file ] unit-test [ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test [ "that" ] [ xml-file get "this" swap at ] unit-test -[ "" ] +[ "" ] [ "" string>xml xml>string ] unit-test [ "abcd" ] [ "

abcd
" string>xml @@ -44,7 +44,7 @@ SYMBOL: xml-file at swap "z" >r tuck r> swap set-at T{ name f "blah" "z" f } swap at ] unit-test [ "foo" ] [ "" string>xml children>string ] unit-test -[ "bar baz" ] +[ "bar baz" ] [ "bar" string>xml [ " baz" append ] map xml>string ] unit-test -[ "\n\n bar\n" ] +[ "\n\n bar\n" ] [ " bar " string>xml pprint-xml>string ] unit-test diff --git a/extra/xml/tokenize/tokenize.factor b/extra/xml/tokenize/tokenize.factor index d99c306b2b..b2b7d78b3e 100644 --- a/extra/xml/tokenize/tokenize.factor +++ b/extra/xml/tokenize/tokenize.factor @@ -172,7 +172,7 @@ SYMBOL: ns-stack [ T{ name f "" "version" f } swap at [ good-version ] [ 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* ; diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor index d6814851ee..b397e3c7b1 100755 --- a/extra/xml/utilities/utilities.factor +++ b/extra/xml/utilities/utilities.factor @@ -42,7 +42,7 @@ M: process-missing error. >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 { } ; diff --git a/extra/xml/xml.factor b/extra/xml/xml.factor index 970ff39cf1..61ef27b72e 100644 --- a/extra/xml/xml.factor +++ b/extra/xml/xml.factor @@ -63,7 +63,7 @@ M: closer process V{ } clone xml-stack set f push-xml ; : default-prolog ( -- prolog ) - "1.0" "iso-8859-1" f ; + "1.0" "UTF-8" f ; : reset-prolog ( -- ) default-prolog prolog-data set ; From 4d8d25ecb336ff486755334d90f1f09b2f352463 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 25 Mar 2008 21:58:27 -0500 Subject: [PATCH 171/886] Update .gitignore --- .gitignore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 7e1e52d866..f2cf3de119 100644 --- a/.gitignore +++ b/.gitignore @@ -18,4 +18,4 @@ factor temp logs work -buildsupport/wordsize +build-support/wordsize From 8569d18068dbaebeb28a4984af87dcbb3dda89ff Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 26 Mar 2008 16:08:14 +1300 Subject: [PATCH 172/886] Use new slots in peg --- extra/peg/peg.factor | 46 ++++++++++++++++++++++---------------------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index ae5ed2f8b2..79c866c768 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -3,7 +3,7 @@ USING: kernel sequences strings namespaces math assocs shuffle vectors arrays combinators.lib math.parser match unicode.categories sequences.lib compiler.units parser - words quotations effects memoize ; + words quotations effects memoize accessors ; IN: peg TUPLE: parse-result remaining ast ; @@ -52,7 +52,7 @@ MATCH-VARS: ?token ; ] if ; M: token-parser (compile) ( parser -- quot ) - token-parser-symbol [ parse-token ] curry ; + symbol>> [ parse-token ] curry ; TUPLE: satisfy-parser quot ; @@ -72,7 +72,7 @@ MATCH-VARS: ?quot ; ] ; M: satisfy-parser (compile) ( parser -- quot ) - satisfy-parser-quot \ ?quot satisfy-pattern match-replace ; + quot>> \ ?quot satisfy-pattern match-replace ; TUPLE: range-parser min max ; @@ -100,12 +100,12 @@ TUPLE: seq-parser parsers ; : seq-pattern ( -- quot ) [ dup [ - dup parse-result-remaining ?quot [ - [ parse-result-remaining swap set-parse-result-remaining ] 2keep - parse-result-ast dup ignore = [ + dup remaining>> ?quot [ + [ remaining>> swap (>>remaining) ] 2keep + ast>> dup ignore = [ drop ] [ - swap [ parse-result-ast push ] keep + swap [ ast>> push ] keep ] if ] [ drop f @@ -118,7 +118,7 @@ TUPLE: seq-parser parsers ; M: seq-parser (compile) ( parser -- quot ) [ [ V{ } clone ] % - seq-parser-parsers [ compiled-parser \ ?quot seq-pattern match-replace % ] each + parsers>> [ compiled-parser \ ?quot seq-pattern match-replace % ] each ] [ ] make ; TUPLE: choice-parser parsers ; @@ -135,16 +135,16 @@ TUPLE: choice-parser parsers ; M: choice-parser (compile) ( parser -- quot ) [ f , - choice-parser-parsers [ compiled-parser \ ?quot choice-pattern match-replace % ] each + parsers>> [ compiled-parser \ ?quot choice-pattern match-replace % ] each \ nip , ] [ ] 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 + 2dup remaining>> swap call [ + [ remaining>> swap (>>remaining) ] 2keep + ast>> swap [ ast>> push ] keep (repeat0) ] [ nip @@ -158,7 +158,7 @@ TUPLE: repeat0-parser p1 ; M: repeat0-parser (compile) ( parser -- quot ) [ [ V{ } clone ] % - repeat0-parser-p1 compiled-parser \ ?quot repeat0-pattern match-replace % + p1>> compiled-parser \ ?quot repeat0-pattern match-replace % ] [ ] make ; TUPLE: repeat1-parser p1 ; @@ -166,7 +166,7 @@ TUPLE: repeat1-parser p1 ; : repeat1-pattern ( -- quot ) [ [ ?quot ] swap (repeat0) [ - dup parse-result-ast empty? [ + dup ast>> empty? [ drop f ] when ] [ @@ -177,7 +177,7 @@ TUPLE: repeat1-parser p1 ; M: repeat1-parser (compile) ( parser -- quot ) [ [ V{ } clone ] % - repeat1-parser-p1 compiled-parser \ ?quot repeat1-pattern match-replace % + p1>> compiled-parser \ ?quot repeat1-pattern match-replace % ] [ ] make ; TUPLE: optional-parser p1 ; @@ -188,7 +188,7 @@ TUPLE: optional-parser p1 ; ] ; M: optional-parser (compile) ( parser -- quot ) - optional-parser-p1 compiled-parser \ ?quot optional-pattern match-replace ; + p1>> compiled-parser \ ?quot optional-pattern match-replace ; TUPLE: ensure-parser p1 ; @@ -202,7 +202,7 @@ TUPLE: ensure-parser p1 ; ] ; M: ensure-parser (compile) ( parser -- quot ) - ensure-parser-p1 compiled-parser \ ?quot ensure-pattern match-replace ; + p1>> compiled-parser \ ?quot ensure-pattern match-replace ; TUPLE: ensure-not-parser p1 ; @@ -216,7 +216,7 @@ TUPLE: ensure-not-parser p1 ; ] ; M: ensure-not-parser (compile) ( parser -- quot ) - ensure-not-parser-p1 compiled-parser \ ?quot ensure-not-pattern match-replace ; + p1>> compiled-parser \ ?quot ensure-not-pattern match-replace ; TUPLE: action-parser p1 quot ; @@ -225,13 +225,13 @@ MATCH-VARS: ?action ; : action-pattern ( -- quot ) [ ?quot dup [ - dup parse-result-ast ?action call - swap [ set-parse-result-ast ] keep + dup ast>> ?action call + >>ast ] when ] ; M: action-parser (compile) ( parser -- quot ) - { action-parser-p1 action-parser-quot } get-slots [ compiled-parser ] dip + { p1>> quot>> } get-slots [ compiled-parser ] dip 2array { ?quot ?action } action-pattern match-replace ; : left-trim-slice ( string -- string ) @@ -245,7 +245,7 @@ TUPLE: sp-parser p1 ; M: sp-parser (compile) ( parser -- quot ) [ - \ left-trim-slice , sp-parser-p1 compiled-parser , + \ left-trim-slice , p1>> compiled-parser , ] [ ] make ; TUPLE: delay-parser quot ; @@ -255,7 +255,7 @@ M: delay-parser (compile) ( parser -- quot ) #! This way it is run only once and the #! parser constructed once at run time. [ - delay-parser-quot % \ compile , + quot>> % \ compile , ] [ ] make { } { "word" } memoize-quot [ % \ execute , ] [ ] make ; From 1ec945ba4c3b6380f3fe7a3a6d8decc5ffa315fb Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 26 Mar 2008 16:16:23 +1300 Subject: [PATCH 173/886] Use new slots in peg.ebnf --- extra/peg/ebnf/ebnf.factor | 40 +++++++++++++++++++++----------------- 1 file changed, 22 insertions(+), 18 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index db478e571f..11e1e2ea64 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -3,7 +3,7 @@ USING: kernel compiler.units parser words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg peg.parsers unicode.categories multiline combinators.lib - splitting ; + splitting accessors ; IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; @@ -16,7 +16,7 @@ TUPLE: ebnf-choice options ; TUPLE: ebnf-sequence elements ; TUPLE: ebnf-repeat0 group ; TUPLE: ebnf-repeat1 group ; -TUPLE: ebnf-optional elements ; +TUPLE: ebnf-optional group ; TUPLE: ebnf-rule symbol elements ; TUPLE: ebnf-action parser code ; TUPLE: ebnf rules ; @@ -198,7 +198,7 @@ DEFER: 'choice' : 'rule' ( -- parser ) [ - 'non-terminal' [ ebnf-non-terminal-symbol ] action , + 'non-terminal' [ symbol>> ] action , "=" syntax , 'choice' , ] seq* [ first2 ] action ; @@ -215,49 +215,53 @@ SYMBOL: main H{ } clone dup dup [ parser set swap (transform) main set ] bind ; M: ebnf (transform) ( ast -- parser ) - ebnf-rules [ (transform) ] map peek ; + rules>> [ (transform) ] map peek ; M: ebnf-rule (transform) ( ast -- parser ) - dup ebnf-rule-elements (transform) [ - swap ebnf-rule-symbol set + dup elements>> (transform) [ + swap symbol>> set ] keep ; M: ebnf-sequence (transform) ( ast -- parser ) - ebnf-sequence-elements [ (transform) ] map seq ; + elements>> [ (transform) ] map seq ; M: ebnf-choice (transform) ( ast -- parser ) - ebnf-choice-options [ (transform) ] map choice ; + options>> [ (transform) ] map choice ; M: ebnf-any-character (transform) ( ast -- parser ) drop any-char ; M: ebnf-range (transform) ( ast -- parser ) - ebnf-range-pattern range-pattern ; + pattern>> range-pattern ; + +: transform-group ( ast -- parser ) + #! convert a ast node with groups to a parser for that group + group>> (transform) ; M: ebnf-ensure (transform) ( ast -- parser ) - ebnf-ensure-group (transform) ensure ; + transform-group ensure ; M: ebnf-ensure-not (transform) ( ast -- parser ) - ebnf-ensure-not-group (transform) ensure-not ; + transform-group ensure-not ; M: ebnf-repeat0 (transform) ( ast -- parser ) - ebnf-repeat0-group (transform) repeat0 ; + transform-group repeat0 ; M: ebnf-repeat1 (transform) ( ast -- parser ) - ebnf-repeat1-group (transform) repeat1 ; + transform-group repeat1 ; M: ebnf-optional (transform) ( ast -- parser ) - ebnf-optional-elements (transform) optional ; + transform-group optional ; M: ebnf-action (transform) ( ast -- parser ) - [ ebnf-action-parser (transform) ] keep - ebnf-action-code string-lines [ parse-lines ] with-compilation-unit action ; + [ parser>> (transform) ] keep + code>> string-lines [ parse-lines ] with-compilation-unit action ; M: ebnf-terminal (transform) ( ast -- parser ) - ebnf-terminal-symbol token sp ; + symbol>> token sp ; M: ebnf-non-terminal (transform) ( ast -- parser ) - ebnf-non-terminal-symbol [ + symbol>> [ , parser get , \ at , ] [ ] make delay sp ; From de3e4e049fdaf177d85553508b888abd9b3a09cf Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 26 Mar 2008 16:21:33 +1300 Subject: [PATCH 174/886] Use cleave instead of get-slots in peg --- extra/peg/peg.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 79c866c768..00271a9ad3 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -3,7 +3,7 @@ USING: kernel sequences strings namespaces math assocs shuffle vectors arrays combinators.lib math.parser match unicode.categories sequences.lib compiler.units parser - words quotations effects memoize accessors ; + words quotations effects memoize accessors combinators.cleave ; IN: peg TUPLE: parse-result remaining ast ; @@ -231,7 +231,7 @@ MATCH-VARS: ?action ; ] ; M: action-parser (compile) ( parser -- quot ) - { p1>> quot>> } get-slots [ compiled-parser ] dip + { [ p1>> ] [ quot>> ] } cleave [ compiled-parser ] dip 2array { ?quot ?action } action-pattern match-replace ; : left-trim-slice ( string -- string ) From 2f73edb3a21a72ddc015c998a9bf29538f971547 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 25 Mar 2008 22:26:33 -0500 Subject: [PATCH 175/886] Fix stat on linux/x86.64 --- extra/unix/stat/linux/64/64.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/unix/stat/linux/64/64.factor b/extra/unix/stat/linux/64/64.factor index be6ad1e3fc..a374551385 100644 --- a/extra/unix/stat/linux/64/64.factor +++ b/extra/unix/stat/linux/64/64.factor @@ -27,5 +27,5 @@ C-STRUCT: stat 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 ; From 257a03ace5ca43014f3bae8322bbdf0c9b1aab26 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Mar 2008 01:30:44 -0500 Subject: [PATCH 176/886] Fix multi-methods load error --- extra/multi-methods/multi-methods.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 9a74cc65e8..42ade34186 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -1,7 +1,7 @@ ! 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 ; IN: multi-methods From e1ad21a439532b7d60e44c6321abb97b59cd0c75 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Mar 2008 03:57:48 -0500 Subject: [PATCH 177/886] Working on shapes --- core/assocs/assocs-tests.factor | 11 +++ core/assocs/assocs.factor | 6 +- core/bootstrap/compiler/compiler.factor | 2 +- core/bootstrap/image/image.factor | 39 ++++++--- core/bootstrap/layouts/layouts.factor | 5 +- core/bootstrap/primitives.factor | 65 ++++++++++++-- core/classes/classes.factor | 7 -- core/compiler/constants/constants.factor | 2 +- core/cpu/ppc/intrinsics/intrinsics.factor | 12 ++- core/cpu/x86/intrinsics/intrinsics.factor | 17 ++-- core/inference/known-words/known-words.factor | 11 +-- core/inference/transforms/transforms.factor | 4 +- core/kernel/kernel.factor | 39 ++++----- core/optimizer/known-words/known-words.factor | 7 +- core/prettyprint/backend/backend.factor | 5 +- core/quotations/quotations.factor | 4 +- core/slots/slots-docs.factor | 2 +- core/slots/slots.factor | 2 +- core/tuples/tuples-docs.factor | 14 +-- core/tuples/tuples.factor | 87 +++++++++++-------- extra/tools/deploy/shaker/shaker.factor | 1 - vm/data_gc.c | 10 ++- vm/debug.c | 31 ++++++- vm/image.c | 56 ++++++++---- vm/layouts.h | 25 +++++- vm/primitives.c | 3 +- vm/run.c | 5 +- vm/types.c | 66 ++++++++------ vm/types.h | 28 +++++- 29 files changed, 378 insertions(+), 188 deletions(-) mode change 100644 => 100755 core/assocs/assocs-tests.factor diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor old mode 100644 new mode 100755 index a0a60e875a..574002921a --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -93,3 +93,14 @@ unit-test ] [ F{ 1.0 2.0 } [ dup ] H{ } map>assoc ] unit-test + +[ { 3 } ] [ + [ + 3 + H{ } clone + 2 [ + 2dup [ , f ] cache + ] times + 2drop + ] make +] unit-test diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index ff0938e001..196ec614b7 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -134,11 +134,11 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) (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 diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 04d57dff16..af2cc79579 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -36,7 +36,7 @@ nl { roll -roll declare not - tuple-class-eq? array? hashtable? vector? + array? hashtable? vector? tuple? sbuf? node? tombstone? array-capacity array-nth set-array-nth diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 6aa4b9212d..7fd4361246 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -4,7 +4,7 @@ USING: alien arrays bit-arrays byte-arrays generic assocs 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 +splitting growable classes tuples tuples.private words.private io.binary io.files vocabs vocabs.loader source-files definitions debugger float-arrays quotations.private sequences.private combinators io.encodings.binary ; @@ -294,17 +294,14 @@ M: bit-array ' bit-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 ; - -: emit-tuple ( obj -- pointer ) +! Tuples +: emit-tuple ( tuple -- pointer ) [ - [ tuple>array unclip transfer-word , % ] { } make - tuple type-number dup emit-array + [ + dup class transfer-word tuple-layout ' , + tuple>array 1 tail-slice [ ' ] map % + ] { } make + tuple type-number dup [ emit-seq ] emit-object ] ! Hack over class word-name "tombstone" = @@ -312,11 +309,31 @@ M: float-array ' float-array emit-dummy-array ; M: tuple ' emit-tuple ; +M: tuple-layout ' + objects get [ + [ + dup layout-hashcode ' , + dup layout-class ' , + dup layout-size ' , + dup layout-superclasses ' , + layout-echelon ' , + ] { } make + \ 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 +: emit-array ( list type tag -- pointer ) + >r >r [ ' ] map r> r> [ + dup length emit-fixnum + emit-seq + ] emit-object ; + M: array ' array type-number object tag-number emit-array ; diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index e15a7b4d7c..316fa3cd72 100755 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -2,13 +2,13 @@ ! 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 tuples tuples.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 } @@ -33,4 +33,5 @@ tag-numbers get H{ { alien 16 } { word 17 } { byte-array 18 } + { tuple-layout 19 } } union type-numbers set diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 0f38839c87..253f23238a 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -3,8 +3,8 @@ USING: alien arrays byte-arrays generic hashtables hashtables.private io kernel math namespaces parser sequences strings vectors words quotations assocs layouts classes tuples -kernel.private vocabs vocabs.loader source-files definitions -slots.deprecated classes.union compiler.units +tuples.private kernel.private vocabs vocabs.loader source-files +definitions slots.deprecated classes.union compiler.units bootstrap.image.private io.files ; IN: bootstrap.primitives @@ -33,7 +33,6 @@ H{ } clone changed-words set H{ } clone root-cache set H{ } clone source-files set H{ } clone update-map set -num-types get f builtins set init-caches ! Vocabulary for slot accessors @@ -47,6 +46,9 @@ call call call +! After we execute bootstrap/layouts +num-types get f builtins set + ! Create some empty vocabs where the below primitives and ! classes will go { @@ -141,8 +143,6 @@ call "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" } @@ -178,8 +178,6 @@ call "f" "syntax" lookup { } define-builtin -! do not word... - "array" "arrays" create { } define-builtin "wrapper" "kernel" create { @@ -293,6 +291,48 @@ define-builtin "callstack" "kernel" create { } define-builtin +"tuple-layout" "tuples.private" create { + { + { "fixnum" "math" } + "hashcode" + { "layout-hashcode" "tuples.private" } + f + } + { + { "word" "words" } + "class" + { "layout-class" "tuples.private" } + f + } + { + { "fixnum" "math" } + "size" + { "layout-size" "tuples.private" } + f + } + { + { "array" "arrays" } + "superclasses" + { "layout-superclasses" "tuples.private" } + f + } + { + { "fixnum" "math" } + "echelon" + { "layout-echelon" "tuples.private" } + f + } +} define-builtin + +"tuple" "kernel" create { + { + { "tuple-layout" "tuples.private" } + "layout" + { "tuple-layout" "tuples.private" } + f + } +} 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 @@ -439,6 +479,10 @@ builtins get num-tags get tail f union-class define-class } } define-tuple-class +"curry" "kernel" lookup +dup f "inline" set-word-prop +dup tuple-layout [ ] curry define + "compose" "kernel" create { { @@ -454,6 +498,10 @@ builtins get num-tags get tail f union-class define-class } } define-tuple-class +"compose" "kernel" lookup +dup f "inline" set-word-prop +dup tuple-layout [ ] curry define + ! Primitive words : make-primitive ( word vocab n -- ) >r create dup reset-word r> @@ -628,11 +676,10 @@ builtins get num-tags get tail f union-class define-class { "" "kernel" } { "(clone)" "kernel" } { "" "strings" } - { "(>tuple)" "tuples.private" } { "array>quotation" "quotations.private" } { "quotation-xt" "quotations" } { "" "tuples.private" } - { "tuple>array" "tuples" } + { "" "tuples.private" } { "profiling" "tools.profiler.private" } { "become" "kernel.private" } { "(sleep)" "threads.private" } diff --git a/core/classes/classes.factor b/core/classes/classes.factor index e5039d8050..b6082ad334 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -118,10 +118,3 @@ GENERIC: update-methods ( assoc -- ) GENERIC: class ( object -- class ) inline M: object class type type>class ; - - diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor index 277a64225a..11f64c9373 100755 --- a/core/compiler/constants/constants.factor +++ b/core/compiler/constants/constants.factor @@ -15,7 +15,7 @@ IN: compiler.constants : 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 - ; diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 91bf5ed1e3..570cd42576 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -479,19 +479,17 @@ IN: cpu.ppc.intrinsics } define-intrinsic \ [ - tuple "n" get 2 + cells %allot - ! Store length - "n" operand 12 LI + tuple "layout" get layout-size 2 + cells %allot + ! Store layout + "layout" operand 12 LOAD32 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 diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index 99a89eab05..dfe136fc6e 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -336,19 +336,20 @@ IN: cpu.x86.intrinsics } define-intrinsic \ [ - 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 diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 08fb56ced7..0de1e0bc53 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -135,7 +135,7 @@ M: object infer-call ! Variadic tuple constructor \ [ \ - peek-d value-literal { tuple } + peek-d value-literal layout-size { tuple } make-call-node ] "infer" set-word-prop @@ -565,14 +565,11 @@ set-primitive-effect \ quotation-xt { quotation } { integer } set-primitive-effect \ quotation-xt make-flushable -\ { word integer } { quotation } set-primitive-effect +\ { tuple-layout } { tuple } set-primitive-effect \ make-flushable -\ (>tuple) { array } { tuple } set-primitive-effect -\ (>tuple) make-flushable - -\ tuple>array { tuple } { array } set-primitive-effect -\ tuple>array make-flushable +\ { word fixnum array fixnum } { tuple-layout } set-primitive-effect +\ make-foldable \ datastack { } { array } set-primitive-effect \ datastack make-flushable diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index a829bad47e..b3a2bffcfe 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -76,7 +76,7 @@ M: duplicated-slots-error summary \ construct-boa [ dup +inlined+ depends-on - dup tuple-size [ ] 2curry + tuple-layout [ ] curry ] 1 define-transform \ construct-empty [ @@ -84,7 +84,7 @@ M: duplicated-slots-error summary peek-d value? [ pop-literal dup +inlined+ depends-on - dup tuple-size [ ] 2curry + tuple-layout [ ] curry swap infer-quot ] [ \ construct-empty 1 1 make-call-node diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 61574e406f..2d99f0793b 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -67,29 +67,7 @@ DEFER: if [ >r tuck 2slip r> while ] [ 2nip call ] if ; inline -! Quotation building -USE: tuples.private - -: curry ( obj quot -- curry ) - \ curry 4 ; - -: 2curry ( obj1 obj2 quot -- curry ) - curry curry ; inline - -: 3curry ( obj1 obj2 obj3 quot -- curry ) - curry curry curry ; inline - -: with ( param obj quot -- obj curry ) - swapd [ swapd call ] 2curry ; inline - -: compose ( quot1 quot2 -- curry ) - \ compose 4 ; - -: 3compose ( quot1 quot2 quot3 -- curry ) - compose compose ; inline - ! Object protocol - GENERIC: delegate ( obj -- delegate ) M: object delegate drop f ; @@ -118,7 +96,6 @@ M: object clone ; M: callstack clone (clone) ; ! Tuple construction - GENERIC# get-slots 1 ( tuple slots -- ... ) GENERIC# set-slots 1 ( ... tuple slots -- ) @@ -132,8 +109,22 @@ GENERIC: construct-boa ( ... class -- tuple ) : construct-delegate ( delegate class -- tuple ) >r { set-delegate } r> construct ; inline -! Booleans +! Quotation building +USE: tuples.private +: 2curry ( obj1 obj2 quot -- curry ) + curry curry ; inline + +: 3curry ( obj1 obj2 obj3 quot -- curry ) + curry curry curry ; inline + +: with ( param obj quot -- obj curry ) + swapd [ swapd call ] 2curry ; inline + +: 3compose ( quot1 quot2 quot3 -- curry ) + compose compose ; inline + +! Booleans : not ( obj -- ? ) f eq? ; inline : >boolean ( obj -- ? ) t f ? ; inline diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 0a3442566c..b56f6fdb06 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -11,12 +11,11 @@ classes.algebra optimizer.def-use optimizer.backend optimizer.pattern-match optimizer.inlining float-arrays sequences.private combinators ; -! the output of and has the class which is -! its second-to-last input { } [ [ - 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 diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index 226595aa4d..5d7b967fc4 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -4,7 +4,7 @@ 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 ; +tuples tuples.private classes float-arrays float-vectors ; IN: prettyprint.backend GENERIC: pprint* ( obj -- ) @@ -202,3 +202,6 @@ M: wrapper pprint* ] [ pprint-object ] if ; + +M: tuple-layout pprint* + "( tuple layout )" swap present-text ; diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 65c6da2b06..693e337959 100755 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -7,9 +7,9 @@ IN: quotations 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 ; diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index e4bb307829..5de765313b 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -12,7 +12,7 @@ ARTICLE: "accessors" "Slot accessors" } "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 "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." diff --git a/core/slots/slots.factor b/core/slots/slots.factor index ed5de3a439..dfd5c1b32a 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -46,7 +46,7 @@ C: slot-spec : define-writer ( class slot name -- ) writer-word [ set-slot ] define-slot-word ; -: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline +: setter-effect T{ effect f { "object" "value" } { "object" } } ; inline : setter-word ( name -- word ) ">>" prepend setter-effect create-accessor ; diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor index 09d93884ad..427c7fbf60 100755 --- a/core/tuples/tuples-docs.factor +++ b/core/tuples/tuples-docs.factor @@ -153,10 +153,6 @@ HELP: tuple= { $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" } "." } ; @@ -246,9 +242,13 @@ 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: ( 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: ( layout -- tuple ) +{ $values { "layout" tuple-layout } { "tuple" tuple } } +{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-empty } "." } ; + +HELP: ( ... 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 construct-boa } "." } ; HELP: construct-empty { $values { "class" tuple-class } { "tuple" tuple } } diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 02ce49d779..56fb12fffc 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! 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 @@ -7,33 +7,55 @@ classes classes.private slots slots.deprecated slots.private compiler.units ; IN: tuples -M: tuple delegate 3 slot ; +M: tuple delegate 2 slot ; -M: tuple set-delegate 3 set-slot ; +M: tuple set-delegate 2 set-slot ; -M: tuple class class-of-tuple ; +M: tuple class 1 slot 2 slot { word } declare ; + +ERROR: no-tuple-class class ; + + + +: check-tuple ( class -- ) + dup tuple-class? + [ drop ] [ no-tuple-class ] if ; + +: tuple>array ( tuple -- array ) + dup tuple-layout + [ layout-size swap [ array-nth ] curry map ] keep + layout-class add* ; + +: >tuple ( sequence -- tuple ) + dup first tuple-layout [ + >r 1 tail-slice dup length r> + [ tuple-size min ] keep + [ set-array-nth ] curry + 2each + ] keep ; r over r> array-nth >r array-nth r> = ] 2curry all-integers? ] [ - 3drop f + 2drop 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) ; + append >tuple ; : reshape-tuples ( class newslots -- ) >r dup "slot-names" word-prop r> permutation @@ -64,42 +86,42 @@ M: tuple class class-of-tuple ; ] unless ] when 2drop ; -GENERIC: tuple-size ( class -- size ) - -M: tuple-class tuple-size "slot-names" word-prop length 2 + ; - -PRIVATE> +M: tuple-class tuple-layout "layout" word-prop ; : define-tuple-predicate ( class -- ) - dup [ tuple-class-eq? ] curry define-predicate ; + dup tuple-layout + [ over tuple? [ swap 1 slot eq? ] [ 2drop f ] if ] curry + define-predicate ; : delegate-slot-spec T{ slot-spec f object "delegate" - 3 + 2 delegate set-delegate } ; : define-tuple-slots ( class slots -- ) - dupd 4 simple-slots + dupd 3 simple-slots 2dup [ slot-spec-name ] map "slot-names" set-word-prop 2dup delegate-slot-spec add* "slots" set-word-prop 2dup define-slots define-accessors ; -ERROR: no-tuple-class class ; +: define-tuple-layout ( class -- ) + dup + dup "slot-names" word-prop length 1+ { } 0 + "layout" set-word-prop ; -: check-tuple ( class -- ) - dup tuple-class? - [ drop ] [ no-tuple-class ] if ; +PRIVATE> : define-tuple-class ( class slots -- ) 2dup check-shape over f tuple tuple-class define-class - over define-tuple-predicate - define-tuple-slots ; + dupd define-tuple-slots + dup define-tuple-layout + define-tuple-predicate ; M: tuple clone (clone) dup delegate clone over set-delegate ; @@ -107,21 +129,14 @@ M: tuple clone 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 [ + dup tuple-size -rot 0 -rot [ swapd array-nth hashcode* bitxor ] 2curry reduce ] recursive-hashcode ; @@ -131,7 +146,7 @@ M: tuple hashcode* ! Definition protocol M: tuple-class reset-class { - "metaclass" "superclass" "slot-names" "slots" + "metaclass" "superclass" "slot-names" "slots" "layout" } reset-props ; M: object get-slots ( obj slots -- ... ) @@ -141,10 +156,10 @@ M: object set-slots ( ... obj slots -- ) get-slots ; M: object construct-empty ( class -- tuple ) - dup tuple-size ; + tuple-layout ; M: object construct ( ... slots class -- tuple ) construct-empty [ swap set-slots ] keep ; M: object construct-boa ( ... class -- tuple ) - dup tuple-size ; + tuple-layout ; diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index f731f5d694..cf23e42283 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -155,7 +155,6 @@ IN: tools.deploy.shaker layouts:tag-numbers layouts:type-numbers lexer-factory - lexer-factory listener:listener-hook root-cache vocab-roots diff --git a/vm/data_gc.c b/vm/data_gc.c index 342bbb6af4..0a1fad575a 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -156,10 +156,12 @@ CELL untagged_object_size(CELL pointer) /* 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: @@ -173,6 +175,10 @@ CELL unaligned_object_size(CELL pointer) 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: @@ -192,6 +198,8 @@ CELL unaligned_object_size(CELL pointer) 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 */ diff --git a/vm/debug.c b/vm/debug.c index 279d925bd7..7e18738afc 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -57,6 +57,35 @@ void print_array(F_ARRAY* array, CELL nesting) 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) @@ -83,7 +112,7 @@ void print_nested_obj(CELL obj, F_FIXNUM nesting) 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: diff --git a/vm/image.c b/vm/image.c index d9f8ac2461..28c6c40c1d 100755 --- a/vm/image.c +++ b/vm/image.c @@ -216,25 +216,45 @@ void fixup_callstack_object(F_CALLSTACK *stack) /* Initialize an object in a newly-loaded image */ void relocate_object(CELL relocating) { - do_slots(relocating,data_fixup); - - switch(untag_header(get(relocating))) + /* 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) { - 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; + data_fixup((CELL *)relocating + 1); + + CELL scan = relocating + 2 * CELLS; + CELL size = untagged_object_size(relocating); + CELL end = relocating + size; + + while(scan < end) + { + data_fixup((CELL *)scan); + scan += CELLS; + } + } + else + { + 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; + } } } diff --git a/vm/layouts.h b/vm/layouts.h index 5ed7c83df2..ff938309e7 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -58,8 +58,9 @@ typedef signed long long s64; #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) { @@ -224,3 +225,25 @@ typedef struct /* 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; diff --git a/vm/primitives.c b/vm/primitives.c index ce26c20f63..203ebb7f6b 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -169,11 +169,10 @@ void *primitives[] = { 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, diff --git a/vm/run.c b/vm/run.c index 2e541a5b6c..d03d999ffd 100755 --- a/vm/run.c +++ b/vm/run.c @@ -320,8 +320,9 @@ DEFINE_PRIMITIVE(class_hash) CELL tag = TAG(obj); if(tag == TUPLE_TYPE) { - F_WORD *class = untag_object(get(SLOT(obj,2))); - drepl(class->hashcode); + F_TUPLE *tuple = untag_object(obj); + F_TUPLE_LAYOUT *layout = untag_object(tuple->layout); + drepl(layout->hashcode); } else if(tag == OBJECT_TYPE) drepl(get(UNTAG(obj))); diff --git a/vm/types.c b/vm/types.c index fb61213385..24bb4cb3ca 100755 --- a/vm/types.c +++ b/vm/types.c @@ -379,45 +379,61 @@ DEFINE_PRIMITIVE(resize_float_array) 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 */ diff --git a/vm/types.h b/vm/types.h index 62b2e06dd0..03ac84d5a5 100755 --- a/vm/types.h +++ b/vm/types.h @@ -96,11 +96,34 @@ DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation) 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); @@ -116,12 +139,11 @@ CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4); 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); From 64203f762d23849b23f0421f20b6123bcd0e6665 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 26 Mar 2008 14:41:09 -0400 Subject: [PATCH 178/886] Docs improvements; simplification of design of io.encodings.8-bit --- core/io/encodings/encodings-docs.factor | 15 +++++--- extra/help/handbook/handbook.factor | 11 ++++-- extra/io/encodings/8-bit/8-bit-docs.factor | 8 +++-- extra/io/encodings/8-bit/8-bit.factor | 41 ++++++++-------------- extra/io/encodings/utf16/utf16-docs.factor | 12 ++++--- 5 files changed, 47 insertions(+), 40 deletions(-) diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index 07e0f9f401..bdd9e56d87 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -19,20 +19,23 @@ HELP: { $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: { $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: { $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 ; { } related-words @@ -58,12 +61,14 @@ ARTICLE: "encodings-protocol" "Encoding protocol" HELP: decode-char { $values { "stream" "an underlying input stream" } { "encoding" "An encoding descriptor tuple" } { "char/f" "a code point or " { $link f } } } -{ $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ; +{ $contract "Reads a single code point from the underlying stream, interpreting it by the encoding." } +$low-level-note ; HELP: encode-char { $values { "char" "a character" } { "stream" "an underlying output stream" } { "encoding" "an encoding descriptor" } } -{ $description "Writes the code point in the encoding to the underlying stream given. This should not be used directly." } ; +{ $contract "Writes the code point in the encoding to the underlying stream given." } +$low-level-note ; { encode-char decode-char } related-words diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 4079386d7f..8963c2b1ad 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -178,9 +178,16 @@ ARTICLE: "encodings-introduction" "An introduction to encodings" "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 "\"filename\" utf8 " } +{ $code "\"file.txt\" utf8 " } "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 "\"filename\" utf8 strict " } ; +{ $code "\"file.txt\" utf8 strict " } +"In a similar way, encodings can be specified when opening a file for writing." +{ $code "\"file.txt\" ascii " } +"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" } diff --git a/extra/io/encodings/8-bit/8-bit-docs.factor b/extra/io/encodings/8-bit/8-bit-docs.factor index 8e5fd815bc..e8dadc13f7 100644 --- a/extra/io/encodings/8-bit/8-bit-docs.factor +++ b/extra/io/encodings/8-bit/8-bit-docs.factor @@ -24,14 +24,18 @@ ARTICLE: "io.encodings.8-bit" "8-bit encodings" { $subsection windows-1252 } { $subsection ebcdic } { $subsection mac-roman } -"Other encodings can be defined using the following utility" +"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" "a string" } { "path" "a path" } } -{ $description "Creates a new encoding with the given name, using the resource file at the path to tell how to encode and decode octets. The resource file should be in a similar format to those at ftp://ftp.unicode.org/Public/MAPPINGS/ISO8859/" } ; +{ $description "Creates a new encoding with the given name, using the resource file at the path to tell how to encode and decode octets. The resource file 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." } diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index c041e699a2..2e33075df0 100644 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -3,7 +3,7 @@ USING: math.parser arrays io.encodings sequences kernel assocs hashtables io.encodings.ascii combinators.cleave generic parser tuples words io io.files splitting namespaces -classes quotations math compiler.units ; +classes quotations math compiler.units accessors ; IN: io.encodings.8-bit ch ] [ ch>byte ] bi ; -: empty-tuple-class ( string -- class ) - in get create - dup { f } "slots" set-word-prop - dup predicate-word drop - dup { } define-tuple-class ; +TUPLE: 8-bit name decode encode ; -: data-quot ( class word data -- quot ) - >r [ word-name ] 2apply "/" swap 3append - "/data" append in get create dup 1quotation swap r> - 1quotation define ; +: encode-8-bit ( char stream assoc -- ) + swapd at* [ encode-error ] unless swap stream-write1 ; -: method-with-data ( class data word quot -- ) - >r swap >r 2dup r> data-quot r> - compose >r create-method r> define ; +M: 8-bit encode-char + encode>> encode-8-bit ; -: encode-8-bit ( char stream encoding assoc -- ) - nip swapd at* [ encode-error ] unless swap stream-write1 ; - -: define-encode-char ( class assoc -- ) - \ encode-char [ encode-8-bit ] method-with-data ; - -: decode-8-bit ( stream encoding array -- char/f ) - nip swap stream-read1 +: decode-8-bit ( stream array -- char/f ) + swap stream-read1 dup [ swap nth [ replacement-char ] unless* ] - [ drop f ] if* ; + [ nip ] if ; -: define-decode-char ( class array -- ) - \ decode-char [ decode-8-bit ] method-with-data ; +M: 8-bit decode-char + decode>> decode-8-bit ; -: 8-bit-methods ( class byte>ch ch>byte -- ) - >r over r> define-encode-char define-decode-char ; +: make-8-bit ( word byte>ch ch>byte -- ) + [ 8-bit construct-boa ] 2curry dupd curry define ; : define-8-bit-encoding ( name path -- ) - >r empty-tuple-class r> parse-file 8-bit-methods ; + >r in get create r> parse-file make-8-bit ; PRIVATE> diff --git a/extra/io/encodings/utf16/utf16-docs.factor b/extra/io/encodings/utf16/utf16-docs.factor index 7198cb2b27..bc0e943415 100644 --- a/extra/io/encodings/utf16/utf16-docs.factor +++ b/extra/io/encodings/utf16/utf16-docs.factor @@ -11,15 +11,19 @@ ARTICLE: "io.encodings.utf16" "UTF-16" 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." } ; +{ $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." } ; +{ $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." } ; +{ $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" } ; 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 in of wide_t*." } ; +{ $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 in of wide_t*." } +{ $see-also "encodings-introduction" } ; { utf16 utf16le utf16be utf16n } related-words From 24466cfc57cd1e7cda29130fef91288e22963f16 Mon Sep 17 00:00:00 2001 From: erg Date: Wed, 26 Mar 2008 22:39:16 -0500 Subject: [PATCH 179/886] normalize-pathname all ova tha place --- core/io/files/files-tests.factor | 7 ++----- core/io/files/files.factor | 6 +++--- extra/io/unix/files/files.factor | 4 ++-- extra/io/unix/launcher/launcher-tests.factor | 14 +++++++++++++- extra/io/unix/launcher/launcher.factor | 5 +++-- extra/io/windows/files/files.factor | 5 ++++- extra/io/windows/windows.factor | 2 +- 7 files changed, 28 insertions(+), 15 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 51bf79e29c..bb8e997c68 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -132,15 +132,12 @@ io.encodings.utf8 ; [ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test [ t ] [ - temp-directory [ "hi" "test41" utf8 set-file-contents ] with-directory + temp-directory [ "hi41" "test41" utf8 set-file-contents ] with-directory temp-directory "test41" append-path utf8 file-contents "hi41" = ] unit-test [ t ] [ - temp-directory [ - "test43" utf8 [ "hi43" write ] with-stream - ] with-directory - temp-directory "test43" append-path utf8 file-contents "hi43" = + temp-directory [ "test41" file-info size>> ] with-directory 4 = ] unit-test [ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 64d8e25ee2..78f1612cb8 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -13,13 +13,13 @@ HOOK: (file-writer) io-backend ( path -- stream ) HOOK: (file-appender) io-backend ( path -- stream ) : ( path encoding -- stream ) - swap (file-reader) swap ; + swap normalize-pathname (file-reader) swap ; : ( path encoding -- stream ) - swap (file-writer) swap ; + swap normalize-pathname (file-writer) swap ; : ( path encoding -- stream ) - swap (file-appender) swap ; + swap normalize-pathname (file-appender) swap ; : file-lines ( path encoding -- seq ) lines ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 1e7d682314..2888231e20 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -94,7 +94,7 @@ M: unix-io copy-file ( from to -- ) \ file-info construct-boa ; M: unix-io file-info ( path -- info ) - stat* stat>file-info ; + normalize-pathname stat* stat>file-info ; M: unix-io link-info ( path -- info ) - lstat* stat>file-info ; + normalize-pathname lstat* stat>file-info ; diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index 9e19245d01..7e527196be 100755 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -1,7 +1,7 @@ IN: io.unix.launcher.tests USING: io.files tools.test io.launcher arrays io namespaces continuations math io.encodings.binary io.encodings.ascii -accessors kernel sequences ; +accessors kernel sequences io.encodings.utf8 ; [ ] [ [ "launcher-test-1" temp-file delete-file ] ignore-errors @@ -95,3 +95,15 @@ accessors kernel sequences ; +replace-environment+ >>environment-mode ascii lines ] unit-test + +[ "hi\n" ] [ + temp-directory [ + [ "aloha" delete-file ] ignore-errors + + { "echo" "hi" } >>command + "aloha" >>stdout + try-process + ] with-directory + temp-directory "aloha" append-path + utf8 file-contents +] unit-test diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 0cbb78b881..1292f2cacf 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -37,7 +37,8 @@ USE: unix 2nip reset-fd ; : redirect-file ( obj mode fd -- ) - >r file-mode open dup io-error r> redirect-fd ; + >r >r normalize-pathname r> file-mode + open dup io-error r> redirect-fd ; : redirect-closed ( obj mode fd -- ) >r >r drop "/dev/null" r> r> redirect-file ; @@ -67,9 +68,9 @@ USE: unix : spawn-process ( process -- * ) [ - current-directory get cd setup-priority setup-redirection + current-directory get cd dup pass-environment? [ dup get-environment set-os-envs ] when diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index 094014fac6..b4513f7da8 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -89,4 +89,7 @@ SYMBOLS: +read-only+ +hidden+ +system+ ] if ; M: windows-nt-io file-info ( path -- info ) - get-file-information-stat ; + normalize-pathname get-file-information-stat ; + +M: windows-nt-io link-info ( path -- info ) + file-info ; diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index dac55664a4..635a992777 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -51,7 +51,7 @@ M: win32-file close-handle ( handle -- ) ! Clean up resources (open handle) if add-completion fails : open-file ( path access-mode create-mode flags -- handle ) [ - >r >r >r normalize-pathname r> + >r >r share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile dup invalid-handle? dup close-later dup add-completion From 5bab5de16d64a49e9157f4e9835a185cd3638c02 Mon Sep 17 00:00:00 2001 From: erg Date: Wed, 26 Mar 2008 22:47:13 -0500 Subject: [PATCH 180/886] make directory work inside with-directory --- core/io/backend/backend.factor | 4 ++-- core/io/files/files-tests.factor | 6 ++++++ 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 8cfcbb71de..151dbc7df7 100755 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -17,10 +17,10 @@ HOOK: io-multiplex io-backend ( ms -- ) HOOK: normalize-directory io-backend ( str -- newstr ) -M: object normalize-directory ; - HOOK: normalize-pathname io-backend ( str -- newstr ) +M: object normalize-directory normalize-pathname ; + : set-io-backend ( io-backend -- ) io-backend set-global init-io init-stdio ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index bb8e997c68..369ecc6868 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -83,6 +83,12 @@ io.encodings.utf8 ; "delete-tree-test" temp-file delete-tree ] unit-test +[ { { "kernel" t } } ] [ + "core" resource-path [ + "." directory [ first "kernel" = ] subset + ] with-directory +] unit-test + [ ] [ "copy-tree-test/a/b/c" temp-file make-directories ] unit-test From f05fef0a630c73b13e60caedae3dec6931d092e0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Mar 2008 23:11:55 -0500 Subject: [PATCH 181/886] Fix PowerPC compiler backend --- core/cpu/ppc/intrinsics/intrinsics.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 570cd42576..8a2f41ec12 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -489,7 +489,7 @@ IN: cpu.ppc.intrinsics ! Store tagged ptr in reg "tuple" get tuple %store-tagged ] H{ - { +input+ { { [ tuple-layout? ] "layout" } } + { +input+ { { [ tuple-layout? ] "layout" } } } { +scratch+ { { f "tuple" } } } { +output+ { "tuple" } } } define-intrinsic From caf3ebb31d9278970cf78bdcc80e98f0f320c121 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 27 Mar 2008 00:32:41 -0400 Subject: [PATCH 182/886] Fixing 8-bit encodings --- extra/io/encodings/8-bit/8-bit.factor | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index 2e33075df0..d29760a3e0 100644 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -3,7 +3,7 @@ USING: math.parser arrays io.encodings sequences kernel assocs hashtables io.encodings.ascii combinators.cleave generic parser tuples words io io.files splitting namespaces -classes quotations math compiler.units accessors ; +math compiler.units accessors ; IN: io.encodings.8-bit ] map ] map ; + [ "\t" split 2 head [ 2 tail-if hex> ] map ] map ; : byte>ch ( assoc -- array ) 256 replacement-char @@ -77,4 +77,8 @@ M: 8-bit decode-char PRIVATE> -[ mappings [ full-path define-8-bit-encoding ] assoc-each ] with-compilation-unit +[ + "io.encodings.8-bit" in [ + mappings [ full-path define-8-bit-encoding ] assoc-each + ] with-variable +] with-compilation-unit From 15c68a23f85a16480cdfe4b8bc74849510153a47 Mon Sep 17 00:00:00 2001 From: erg Date: Wed, 26 Mar 2008 23:47:51 -0500 Subject: [PATCH 183/886] remove ?resource-path and resource-exists? --- core/bootstrap/stage1.factor | 2 +- core/io/files/files-docs.factor | 9 --------- core/io/files/files-tests.factor | 4 ++++ core/io/files/files.factor | 20 +++++++++++-------- core/parser/parser.factor | 4 ++-- core/source-files/source-files.factor | 2 +- core/vocabs/loader/loader.factor | 2 +- extra/editors/editors.factor | 4 ++-- .../templating/fhtml/fhtml-tests.factor | 2 +- .../http/server/templating/fhtml/fhtml.factor | 2 +- extra/project-euler/project-euler.factor | 2 +- extra/tools/deploy/test/3/3.factor | 2 +- extra/tools/vocabs/vocabs.factor | 17 ++++++++-------- extra/ui/freetype/freetype.factor | 2 +- 14 files changed, 36 insertions(+), 38 deletions(-) diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 74b4d03cbb..34f758c9df 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -39,7 +39,7 @@ vocabs.loader system debugger continuations ; [ "resource:core/bootstrap/stage2.factor" - dup resource-exists? [ + dup exists? [ [ run-file ] [ :c diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 1a3bde0e5c..1953569223 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -20,9 +20,6 @@ ARTICLE: "pathnames" "Pathname manipulation" { $subsection file-name } { $subsection last-path-separator } { $subsection append-path } -"Pathnames relative to Factor's install directory:" -{ $subsection resource-path } -{ $subsection ?resource-path } "Pathnames relative to Factor's temporary files directory:" { $subsection temp-directory } { $subsection temp-file } @@ -248,12 +245,6 @@ 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 - HELP: pathname { $class-description "Class of pathname presentations. Path name presentations can be created by calling " { $link } ". Instances can be passed to " { $link write-object } " to output a clickable pathname." } ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 369ecc6868..9af82a5672 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -205,3 +205,7 @@ io.encodings.utf8 ; [ "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 +[ t ] [ "/foo" absolute-path? ] unit-test +[ f ] [ "" absolute-path? ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 78f1612cb8..0090f90e4c 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -99,7 +99,12 @@ ERROR: no-parent-directory path ; PRIVATE> : absolute-path? ( path -- ? ) - dup empty? [ drop f ] [ first path-separator? ] if ; + { + { [ dup empty? ] [ f ] } + { [ dup "resource:" head? ] [ t ] } + { [ dup first path-separator? ] [ t ] } + { [ t ] [ f ] } + } cond nip ; : append-path ( str1 str2 -- str ) { @@ -258,12 +263,6 @@ DEFER: copy-tree-into "resource-path" get [ image parent-directory ] unless* prepend-path ; -: ?resource-path ( path -- newpath ) - "resource:" ?head [ left-trim-separators resource-path ] when ; - -: resource-exists? ( path -- ? ) - ?resource-path exists? ; - : temp-directory ( -- path ) "temp" resource-path dup exists? not @@ -273,7 +272,12 @@ DEFER: copy-tree-into : temp-file ( name -- path ) temp-directory prepend-path ; M: object normalize-pathname ( path -- path' ) - current-directory get prepend-path ; + "resource:" ?head [ + left-trim-separators resource-path + normalize-pathname + ] [ + current-directory get prepend-path + ] if ; ! Pathname presentations TUPLE: pathname string ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index bb3ad254da..f6e351a42e 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -520,7 +520,7 @@ SYMBOL: interactive-vocabs [ [ [ parsing-file ] keep - [ ?resource-path utf8 ] keep + [ utf8 ] keep parse-stream ] with-compiler-errors ] [ @@ -532,7 +532,7 @@ SYMBOL: interactive-vocabs [ 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 ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index f4428e4e8b..8dea367b6b 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -48,7 +48,7 @@ uses definitions ; : reset-checksums ( -- ) source-files get [ - swap ?resource-path dup exists? [ + swap dup exists? [ utf8 file-lines swap record-checksum ] [ 2drop ] if ] assoc-each ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 9478c1f4f7..57947eefb0 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -25,7 +25,7 @@ V{ : vocab-dir? ( root name -- ? ) over [ - ".factor" vocab-dir+ append-path resource-exists? + ".factor" vocab-dir+ append-path exists? ] [ 2drop f ] if ; diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index 4ee906bccb..89aef4d819 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -26,7 +26,7 @@ SYMBOL: edit-hook : edit-location ( file line -- ) edit-hook get [ - >r >r ?resource-path r> r> call + call ] [ no-edit-hook edit-location ] if* ; @@ -39,7 +39,7 @@ SYMBOL: edit-hook : :edit ( -- ) error get delegates [ parse-error? ] find-last nip [ - dup parse-error-file source-file-path ?resource-path + dup parse-error-file source-file-path swap parse-error-line edit-location ] when* ; diff --git a/extra/http/server/templating/fhtml/fhtml-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor index 2e253d9132..9d8a6f4617 100755 --- a/extra/http/server/templating/fhtml/fhtml-tests.factor +++ b/extra/http/server/templating/fhtml/fhtml-tests.factor @@ -9,7 +9,7 @@ IN: http.server.templating.fhtml.tests [ ".fhtml" append [ run-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 diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor index 630054ccfa..f3d9d54a25 100755 --- a/extra/http/server/templating/fhtml/fhtml.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -83,7 +83,7 @@ DEFER: <% delimiter 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 ; diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 04339ad5b7..9325e74d93 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -31,7 +31,7 @@ IN: project-euler : solution-path ( n -- str/f ) number>euler "project-euler." prepend - vocab where dup [ first ?resource-path ] when ; + vocab where dup [ first ] when ; PRIVATE> diff --git a/extra/tools/deploy/test/3/3.factor b/extra/tools/deploy/test/3/3.factor index 443e82f7d9..2f07f4ede5 100755 --- a/extra/tools/deploy/test/3/3.factor +++ b/extra/tools/deploy/test/3/3.factor @@ -3,6 +3,6 @@ USING: io.encodings.ascii io.files kernel ; : deploy-test-3 "resource:extra/tools/deploy/test/3/3.factor" - ?resource-path ascii file-contents drop ; + ascii file-contents drop ; MAIN: deploy-test-3 diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index b086b30a5e..d7c3d2be20 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -8,12 +8,12 @@ IN: tools.vocabs : vocab-tests-file ( vocab -- path ) dup "-tests.factor" vocab-dir+ vocab-append-path dup - [ dup resource-exists? [ drop f ] unless ] [ drop f ] if ; + [ dup exists? [ drop f ] unless ] [ drop f ] if ; : vocab-tests-dir ( vocab -- paths ) dup vocab-dir "tests" append-path vocab-append-path dup [ - dup resource-exists? [ - dup ?resource-path directory keys + dup exists? [ + dup directory keys [ ".factor" tail? ] subset [ append-path ] with map ] [ drop f ] if @@ -34,7 +34,7 @@ IN: tools.vocabs : source-modified? ( path -- ? ) dup source-files get at [ - dup source-file-path ?resource-path + dup source-file-path dup exists? [ utf8 file-lines lines-crc32 swap source-file-checksum = not @@ -42,7 +42,7 @@ IN: tools.vocabs 2drop f ] if ] [ - resource-exists? + exists? ] ?if ; : modified ( seq quot -- seq ) @@ -104,15 +104,14 @@ SYMBOL: sources-changed? "" refresh f sources-changed? set-global ; MEMO: (vocab-file-contents) ( path -- lines ) - ?resource-path dup exists? - [ utf8 file-lines ] [ drop f ] if ; + dup exists? [ utf8 file-lines ] [ drop f ] if ; : vocab-file-contents ( vocab name -- seq ) vocab-append-path dup [ (vocab-file-contents) ] when ; : set-vocab-file-contents ( seq vocab name -- ) dupd vocab-append-path [ - ?resource-path utf8 set-file-lines + utf8 set-file-lines \ (vocab-file-contents) reset-memoized ] [ "The " swap vocab-name @@ -171,7 +170,7 @@ M: vocab-link summary vocab-summary ; directory [ second ] subset keys natural-sort ; : (all-child-vocabs) ( root name -- vocabs ) - [ vocab-dir append-path ?resource-path subdirs ] keep + [ vocab-dir append-path subdirs ] keep dup empty? [ drop ] [ diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index dc56009b87..1963f5670a 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -62,7 +62,7 @@ M: freetype-renderer free-fonts ( world -- ) } at ; : ttf-path ( name -- string ) - "resource: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 From 8903ba3a32257e4c99ac3c41496ea7f0527a13ff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 01:41:22 -0500 Subject: [PATCH 184/886] Fix Windows bootstrap --- extra/io/windows/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index b4513f7da8..655b5f9daf 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types io.files io.windows kernel +USING: alien.c-types io.backend io.files io.windows kernel math windows windows.kernel32 combinators.cleave windows.time calendar combinators math.functions sequences namespaces words symbols ; From 5aae4516dde997ff042211b9a584de02bb9db9e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 01:42:13 -0500 Subject: [PATCH 185/886] Working on slot inheritance --- core/bootstrap/primitives.factor | 18 +++++--- core/classes/classes.factor | 3 ++ core/mirrors/mirrors.factor | 2 +- core/tuples/tuples-tests.factor | 26 ++++++++++-- core/tuples/tuples.factor | 71 ++++++++++++++++++++++---------- 5 files changed, 89 insertions(+), 31 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 3f6fedb40c..baa85032bc 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -324,14 +324,20 @@ define-builtin } } define-builtin -"tuple" "kernel" create { +"tuple" "kernel" create { } define-builtin + +"tuple" "kernel" lookup +{ { - { "tuple-layout" "tuples.private" } - "layout" - { "tuple-layout" "tuples.private" } - f + { "object" "kernel" } + "delegate" + { "delegate" "kernel" } + { "set-delegate" "kernel" } } -} define-builtin +} +define-tuple-slots + +"tuple" "kernel" lookup define-tuple-layout ! Define general-t type, which is any object that is not f. "general-t" "kernel" create diff --git a/core/classes/classes.factor b/core/classes/classes.factor index c2c19836cd..c21dd452ac 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -57,6 +57,9 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ; #! Output f for non-classes to work with algebra code dup class? [ "superclass" word-prop ] [ drop f ] if ; +: superclasses ( class -- supers ) + [ dup ] [ dup superclass swap ] [ ] unfold reverse nip ; + : members ( class -- seq ) #! Output f for non-classes to work with algebra code dup class? [ "members" word-prop ] [ drop f ] if ; diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index 8f12bbb2f4..7176076c7c 100755 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -10,7 +10,7 @@ GENERIC: object-slots ( obj -- seq ) M: object object-slots class "slots" word-prop ; M: tuple object-slots - dup class "slots" word-prop + dup class superclasses [ "slots" word-prop ] map concat swap delegate [ 1 tail-slice ] unless ; TUPLE: mirror object slots ; diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index 2d28697b70..e670c26c25 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -246,6 +246,7 @@ C: erg's-reshape-problem ! Inheritance TUPLE: computer cpu ram ; +C: computer [ "TUPLE: computer cpu ram ;" ] [ [ \ computer see ] with-string-writer string-lines second @@ -264,11 +265,23 @@ C: laptop [ t ] [ "laptop" get computer? ] unit-test [ t ] [ "laptop" get tuple? ] unit-test +[ "Pentium" ] [ "laptop" get cpu>> ] unit-test +[ 128 ] [ "laptop" get ram>> ] unit-test +[ t ] [ "laptop" get battery>> 3 hours = ] unit-test + +[ 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: server < computer rackmount? ; +[ { tuple computer laptop } ] [ laptop superclasses ] unit-test + +TUPLE: server < computer rackmount ; C: server [ t ] [ server tuple-class? ] unit-test @@ -276,11 +289,15 @@ C: server [ t ] [ server computer class< ] unit-test [ t ] [ server computer classes-intersect? ] unit-test -[ ] [ "Pentium" 128 "1U" "server" set ] unit-test +[ ] [ "PowerPC" 64 "1U" "server" set ] unit-test [ t ] [ "server" get server? ] unit-test [ t ] [ "server" get computer? ] unit-test [ t ] [ "server" get tuple? ] unit-test +[ "PowerPC" ] [ "server" get cpu>> ] unit-test +[ 64 ] [ "server" get ram>> ] unit-test +[ "1U" ] [ "server" get rackmount>> ] unit-test + [ f ] [ "server" get laptop? ] unit-test [ f ] [ "laptop" get server? ] unit-test @@ -288,7 +305,10 @@ C: server [ f ] [ laptop server class< ] unit-test [ f ] [ laptop server classes-intersect? ] unit-test -[ "TUPLE: server < computer rackmount? ;" ] [ +[ f ] [ 1 2 laptop? ] unit-test +[ f ] [ \ + server? ] unit-test + +[ "TUPLE: server < computer rackmount ;" ] [ [ \ server see ] with-string-writer string-lines second ] unit-test diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 83f398242a..09dd03de2f 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -4,7 +4,7 @@ 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 ; +compiler.units math.private ; IN: tuples M: tuple delegate 2 slot ; @@ -17,6 +17,12 @@ ERROR: no-tuple-class class ; @@ -49,33 +55,56 @@ PRIVATE> 2drop f ] if ; -M: tuple-class tuple-layout "layout" word-prop ; +! 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-layout - [ over tuple? [ swap 1 slot eq? ] [ 2drop f ] if ] curry - define-predicate ; + dup tuple-predicate-quot define-predicate ; -: delegate-slot-spec - T{ slot-spec f - object - "delegate" - 2 - delegate - set-delegate - } ; +: superclass-size ( class -- n ) + superclasses 1 head-slice* + [ "slot-names" word-prop length ] map sum ; + +: generate-tuple-slots ( class slots -- slot-specs slot-names ) + over superclass-size 2 + simple-slots + dup [ slot-spec-name ] map ; : define-tuple-slots ( class slots -- ) - dupd 3 simple-slots - 2dup [ slot-spec-name ] map "slot-names" set-word-prop - 2dup delegate-slot-spec add* "slots" set-word-prop - 2dup define-slots - define-accessors ; + dupd generate-tuple-slots + >r dupd "slots" set-word-prop + r> dupd "slot-names" set-word-prop + dup "slots" word-prop 2dup define-slots define-accessors ; + +: make-tuple-layout ( class -- layout ) + dup superclass-size over "slot-names" word-prop length + + over superclasses dup length 1- ; : define-tuple-layout ( class -- ) - dup - dup "slot-names" word-prop length 1+ { } 0 - "layout" set-word-prop ; + dup make-tuple-layout "layout" set-word-prop ; : removed-slots ( class newslots -- seq ) swap "slot-names" word-prop seq-diff ; From f1ee3dcb32e61b47f92fe5de911f4a24ea4bc7d8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 02:12:15 -0500 Subject: [PATCH 186/886] Clean up temp-directory --- core/io/files/files.factor | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 78f1612cb8..7cdf41674d 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -265,12 +265,10 @@ DEFER: copy-tree-into ?resource-path exists? ; : temp-directory ( -- path ) - "temp" resource-path - dup exists? not - [ dup make-directory ] - when ; + "temp" resource-path dup make-directories ; -: temp-file ( name -- path ) temp-directory prepend-path ; +: temp-file ( name -- path ) + temp-directory prepend-path ; M: object normalize-pathname ( path -- path' ) current-directory get prepend-path ; From b008f69c25c4c39b394559b107830ed44e6c6bc1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 03:27:22 -0500 Subject: [PATCH 187/886] Fix serialize --- extra/serialize/serialize.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index 7bcc336962..a86eee71e3 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -269,7 +269,7 @@ SYMBOL: deserialized [ ] 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 From febcd88459f0e8a04189eb365c5a530b94a05493 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 05:13:52 -0500 Subject: [PATCH 188/886] Unit test fixes --- core/assocs/assocs-tests.factor | 4 ++-- core/classes/algebra/algebra-docs.factor | 2 +- core/compiler/tests/templates.factor | 4 ++-- core/mirrors/mirrors-tests.factor | 2 +- core/mirrors/mirrors.factor | 10 ++++------ core/tuples/tuples-docs.factor | 2 +- core/tuples/tuples.factor | 2 +- extra/inverse/inverse.factor | 4 ++-- extra/tuple-syntax/tuple-syntax.factor | 5 ++--- extra/tuples/lib/lib.factor | 6 +++--- 10 files changed, 19 insertions(+), 22 deletions(-) mode change 100644 => 100755 extra/tuples/lib/lib.factor diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 574002921a..c4db604784 100755 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -99,8 +99,8 @@ unit-test 3 H{ } clone 2 [ - 2dup [ , f ] cache + 2dup [ , f ] cache drop ] times 2drop - ] make + ] { } make ] unit-test diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor index 632af1d040..87c72048f4 100755 --- a/core/classes/algebra/algebra-docs.factor +++ b/core/classes/algebra/algebra-docs.factor @@ -30,7 +30,7 @@ HELP: class-types { $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ; HELP: class< -{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } } +{ $values { "first" "a class" } { "second" "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" } "." } ; diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 1c19730ec0..8a33d57fe7 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -81,8 +81,8 @@ unit-test -12 -13 [ [ 0 swap fixnum- ] 2apply ] 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 diff --git a/core/mirrors/mirrors-tests.factor b/core/mirrors/mirrors-tests.factor index 8f2964b19d..11e5772000 100755 --- a/core/mirrors/mirrors-tests.factor +++ b/core/mirrors/mirrors-tests.factor @@ -5,7 +5,7 @@ TUPLE: foo bar baz ; C: foo -[ { "bar" "baz" } ] [ 1 2 keys ] unit-test +[ { "delegate" "bar" "baz" } ] [ 1 2 keys ] unit-test [ 1 t ] [ "bar" 1 2 at* ] unit-test diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index 7176076c7c..3c5a0aa3c7 100755 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -5,13 +5,11 @@ arrays classes slots slots.private tuples math vectors quotations sorting prettyprint ; 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 superclasses [ "slots" word-prop ] map concat - swap delegate [ 1 tail-slice ] unless ; +: object-slots ( obj -- seq ) + class all-slots ; TUPLE: mirror object slots ; diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor index 6e0f319c9a..55e15d6dc6 100755 --- a/core/tuples/tuples-docs.factor +++ b/core/tuples/tuples-docs.factor @@ -191,7 +191,7 @@ HELP: define-tuple-predicate $low-level-note ; HELP: redefine-tuple-class -{ $values { "class" class } { "superclass" class } { "newslots" "a sequence of strings" } } +{ $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." } diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 09dd03de2f..89aff6f185 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -36,7 +36,7 @@ PRIVATE> [ layout-size swap [ array-nth ] curry map ] keep layout-class add* ; -: >tuple ( sequence -- tuple ) +: >tuple ( seq -- tuple ) dup first tuple-layout [ >r 1 tail-slice dup length r> [ tuple-size min ] keep diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 1468065ebe..308bf36bf4 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -1,7 +1,7 @@ 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 ; +math.functions macros sequences.private combinators mirrors ; IN: inverse TUPLE: fail ; @@ -191,7 +191,7 @@ MACRO: undo ( quot -- ) [undo] ; "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 ; diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor index 2f0ba6bde5..f06bb55899 100755 --- a/extra/tuple-syntax/tuple-syntax.factor +++ b/extra/tuple-syntax/tuple-syntax.factor @@ -1,5 +1,5 @@ USING: kernel sequences slots parser words classes -slots.private ; +slots.private mirrors ; IN: tuple-syntax ! TUPLE: foo bar baz ; @@ -10,8 +10,7 @@ IN: tuple-syntax : 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 ) diff --git a/extra/tuples/lib/lib.factor b/extra/tuples/lib/lib.factor old mode 100644 new mode 100755 index 5075c1d94a..4c007c8bb1 --- a/extra/tuples/lib/lib.factor +++ b/extra/tuples/lib/lib.factor @@ -1,16 +1,16 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel macros sequences slots words ; +USING: kernel macros sequences slots words mirrors ; 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 ; + all-slots 1 tail-slice reader-slots ; MACRO: >tuple*< ( class -- ) - "slots" word-prop + all-slots [ slot-spec-name "*" tail? ] subset reader-slots ; From 65bfc092652a60152af35e87cad5cb0ccec911dd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 05:18:07 -0500 Subject: [PATCH 189/886] Fix HTTP server --- extra/http/server/static/static.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 37c3a63d76..2f48e7ac87 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -39,7 +39,9 @@ TUPLE: file-responder root hook special ; [ 2drop <304> ] [ file-responder get hook>> call ] if ; : serving-path ( filename -- filename ) - "" or file-responder get root>> prepend-path ; + file-responder get root>> right-trim-separators + "/" + rot "" or left-trim-separators 3append ; : serve-file ( filename -- response ) dup mime-type From e39894155c1d983e2a6dd5aa358b747305a06806 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 27 Mar 2008 09:00:59 -0500 Subject: [PATCH 190/886] add windows-absolute-path? and move unit tests --- core/io/files/files.factor | 10 +++++++++- extra/io/windows/nt/files/files-tests.factor | 11 +++++++++++ 2 files changed, 20 insertions(+), 1 deletion(-) create mode 100644 extra/io/windows/nt/files/files-tests.factor diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 3913f3c8d5..94401f3e1f 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -3,7 +3,7 @@ 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 init ; +io.encodings.binary init unicode.categories ; IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) @@ -98,11 +98,19 @@ ERROR: no-parent-directory path ; PRIVATE> +: windows-absolute-path? ( path -- path ? ) + { + { [ dup length 2 < ] [ f ] } + { [ dup first2 >r Letter? r> CHAR: : = and ] [ t ] } + { [ t ] [ f ] } + } cond ; + : absolute-path? ( path -- ? ) { { [ dup empty? ] [ f ] } { [ dup "resource:" head? ] [ t ] } { [ dup first path-separator? ] [ t ] } + { [ windows? ] [ windows-absolute-path? ] } { [ t ] [ f ] } } cond nip ; diff --git a/extra/io/windows/nt/files/files-tests.factor b/extra/io/windows/nt/files/files-tests.factor new file mode 100644 index 0000000000..a96bd6dad8 --- /dev/null +++ b/extra/io/windows/nt/files/files-tests.factor @@ -0,0 +1,11 @@ +USING: kernel tools.test ; +IN: io.windows.nt.files.tests + +[ 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 ] [ "//" root-directory? ] unit-test +[ t ] [ "//////////////" root-directory? ] unit-test +[ t ] [ "\\foo" absolute-path? ] unit-test From f54d12682a6608d5fe7ab7b279ef16e21875f896 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 27 Mar 2008 09:01:48 -0500 Subject: [PATCH 191/886] add more unit tests for windows --- extra/io/windows/nt/files/files-tests.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/io/windows/nt/files/files-tests.factor b/extra/io/windows/nt/files/files-tests.factor index a96bd6dad8..3b31d73e4a 100644 --- a/extra/io/windows/nt/files/files-tests.factor +++ b/extra/io/windows/nt/files/files-tests.factor @@ -9,3 +9,7 @@ IN: io.windows.nt.files.tests [ t ] [ "//" root-directory? ] unit-test [ t ] [ "//////////////" root-directory? ] unit-test [ t ] [ "\\foo" absolute-path? ] unit-test +[ t ] [ "\\\\?\\foo" absolute-path? ] unit-test +[ t ] [ "c:\\foo" absolute-path? ] unit-test +[ t ] [ "c:" absolute-path? ] unit-test + From 15139b06ec4c15db960ae6047a0fbbf1152c4343 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 27 Mar 2008 09:06:06 -0500 Subject: [PATCH 192/886] can't use unicode or ascii in io.files.. --- core/io/files/files.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 94401f3e1f..f6888bf78d 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -3,7 +3,7 @@ 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 init unicode.categories ; +io.encodings.binary init ; IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) @@ -101,7 +101,7 @@ PRIVATE> : windows-absolute-path? ( path -- path ? ) { { [ dup length 2 < ] [ f ] } - { [ dup first2 >r Letter? r> CHAR: : = and ] [ t ] } + { [ dup second CHAR: : = ] [ t ] } { [ t ] [ f ] } } cond ; From 783d7a20da52645acbf2711e3aea0513a7c3819d Mon Sep 17 00:00:00 2001 From: "U-FROGGER\\erg" Date: Wed, 26 Mar 2008 10:17:20 -0500 Subject: [PATCH 193/886] fix windows bootstrap --- extra/io/windows/nt/files/files.factor | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 1c8d88c872..c6cbf292b3 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -65,12 +65,17 @@ ERROR: empty-pathname ; USE: tools.walker M: windows-nt-io normalize-pathname ( string -- string ) - dup string? [ nonstring-pathname ] unless - dup empty? [ empty-pathname ] when - { { CHAR: / CHAR: \\ } } substitute - current-directory get swap windows-append-path - [ "/\\." member? ] right-trim - dup peek CHAR: : = [ "\\" append ] when ; + "resource:" ?head [ + left-trim-separators resource-path + normalize-pathname + ] [ + dup string? [ nonstring-pathname ] unless + dup empty? [ empty-pathname ] when + { { CHAR: / CHAR: \\ } } substitute + current-directory get swap windows-append-path + [ "/\\." member? ] right-trim + dup peek CHAR: : = [ "\\" append ] when + ] if ; M: windows-nt-io CreateFile-flags ( DWORD -- DWORD ) FILE_FLAG_OVERLAPPED bitor ; From ecee19e6edc5bf33877da05419e923395e0823a6 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 26 Mar 2008 12:00:09 -0600 Subject: [PATCH 194/886] Add a docs file for openssl. Mention where to get OpenSSL for Windows. --- extra/openssl/openssl-docs.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 extra/openssl/openssl-docs.factor diff --git a/extra/openssl/openssl-docs.factor b/extra/openssl/openssl-docs.factor new file mode 100644 index 0000000000..dd31bfd001 --- /dev/null +++ b/extra/openssl/openssl-docs.factor @@ -0,0 +1,10 @@ + +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 From c300d4482a3038533b4324e4f941fbe830d0574b Mon Sep 17 00:00:00 2001 From: sheeple Date: Thu, 27 Mar 2008 11:14:40 -0500 Subject: [PATCH 195/886] rm staging files in temp/ --- misc/factor.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/misc/factor.sh b/misc/factor.sh index 1fe003994c..09531350f3 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -306,7 +306,7 @@ 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 + 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' '`; From f0a900d11b7446dc7cbbb0d617c517818232ae3d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 17:12:39 -0500 Subject: [PATCH 196/886] Fix Windows bootstrap --- core/io/backend/backend.factor | 6 ++++-- core/io/files/files.factor | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 151dbc7df7..6bcd448385 100755 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -1,6 +1,7 @@ ! 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 ; IN: io.backend SYMBOL: io-backend @@ -22,7 +23,8 @@ HOOK: normalize-pathname io-backend ( str -- newstr ) M: object normalize-directory normalize-pathname ; : 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 diff --git a/core/io/files/files.factor b/core/io/files/files.factor index f6888bf78d..436bf8598d 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -170,7 +170,7 @@ SYMBOL: current-directory M: object cwd ( -- path ) "." ; -[ cwd current-directory set-global ] "current-directory" add-init-hook +[ cwd current-directory set-global ] "io.files" add-init-hook : with-directory ( path quot -- ) current-directory swap with-variable ; inline From 2ff18ddea8f0ae5653eeb979afc5bc13a93f25b6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 17:12:47 -0500 Subject: [PATCH 197/886] Fix editors.jedit --- extra/editors/jedit/jedit.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 extra/editors/jedit/jedit.factor diff --git a/extra/editors/jedit/jedit.factor b/extra/editors/jedit/jedit.factor old mode 100644 new mode 100755 index 7b6066df7c..92320addef --- a/extra/editors/jedit/jedit.factor +++ b/extra/editors/jedit/jedit.factor @@ -8,7 +8,7 @@ io.encodings.utf8 ; IN: editors.jedit : jedit-server-info ( -- port auth ) - home "/.jedit/server" append-path ascii [ + home ".jedit/server" append-path ascii [ readln drop readln string>number readln string>number From 8c5e01703d21074d262cc94663b8efb4178053dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 17:19:48 -0500 Subject: [PATCH 198/886] Fixing deployment --- extra/tools/deploy/macosx/macosx.factor | 17 +++++++++-------- extra/tools/deploy/shaker/shaker.factor | 2 +- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 9fe35647fe..6d9c8e9d8a 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -62,11 +62,12 @@ T{ macosx-deploy-implementation } deploy-implementation set-global M: macosx-deploy-implementation 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 ; diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index cf23e42283..ee9c2b9fab 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -81,7 +81,7 @@ IN: tools.deploy.shaker [ "class" , "metaclass" , - "slot-names" , + "layout" , deploy-ui? get [ "gestures" , "commands" , From f09547ece13321bcc61dd1fa733daf02909472b5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 17:47:04 -0500 Subject: [PATCH 199/886] Fix mirrors docs --- core/mirrors/mirrors-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/mirrors/mirrors-docs.factor b/core/mirrors/mirrors-docs.factor index 29ed153a2e..725a757e61 100755 --- a/core/mirrors/mirrors-docs.factor +++ b/core/mirrors/mirrors-docs.factor @@ -36,7 +36,7 @@ HELP: "TUPLE: circle center radius ;" "C: circle" "{ 100 50 } 15 >alist ." - "{ { \"center\" { 100 50 } } { \"radius\" 15 } }" + "{ { \"delegate\" f } { \"center\" { 100 50 } } { \"radius\" 15 } }" } } ; From 7616eefbfcadc3c4ef551702788267372b4b2782 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 18:00:55 -0500 Subject: [PATCH 200/886] Fix editor integration --- extra/editors/editors.factor | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index 89aef4d819..67e515ebc1 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -25,11 +25,8 @@ SYMBOL: edit-hook require ; : edit-location ( file line -- ) - edit-hook get [ - call - ] [ - no-edit-hook edit-location - ] if* ; + >r current-directory get prepend-path r> + edit-hook get [ call ] [ no-edit-hook edit-location ] if* ; : edit ( defspec -- ) where [ first2 edit-location ] when* ; From d8fc44662286db830264df286be0bb84e91151c0 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 27 Mar 2008 18:13:55 -0500 Subject: [PATCH 201/886] add unit tests and fix lots of words for normalize-pathname --- core/io/files/files-tests.factor | 50 ++++++++++++++++++++++++++++++++ extra/io/unix/files/files.factor | 18 +++++++----- 2 files changed, 60 insertions(+), 8 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index b732495541..b78f7667a6 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -7,6 +7,56 @@ io.encodings.utf8 ; [ ] [ "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 diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 2888231e20..ca5d7a7bf1 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -7,11 +7,11 @@ calendar io.encodings.binary ; IN: io.unix.files -M: unix-io cwd +M: unix-io cwd ( -- path ) MAXPATHLEN [ ] [ ] bi getcwd [ (io-error) ] unless* ; -M: unix-io cd +M: unix-io cd ( path -- ) chdir io-error ; : read-flags O_RDONLY ; inline @@ -39,25 +39,26 @@ M: unix-io (file-writer) ( path -- stream ) M: unix-io (file-appender) ( path -- stream ) open-append ; -: touch-mode +: touch-mode ( -- n ) { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable M: unix-io touch-file ( path -- ) + normalize-pathname 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 ; + [ normalize-pathname ] 2apply rename io-error ; M: unix-io delete-file ( path -- ) - unlink io-error ; + normalize-pathname unlink io-error ; M: unix-io make-directory ( path -- ) - OCT: 777 mkdir io-error ; + normalize-pathname OCT: 777 mkdir io-error ; M: unix-io delete-directory ( path -- ) - rmdir io-error ; + normalize-pathname rmdir io-error ; : (copy-file) ( from to -- ) dup parent-directory make-directories @@ -68,8 +69,9 @@ M: unix-io delete-directory ( path -- ) ] with-disposal ; M: unix-io copy-file ( from to -- ) + [ normalize-pathname ] 2apply [ (copy-file) ] - [ swap file-info file-info-permissions chmod io-error ] + [ swap file-info file-info-permissions chmod io-error ] 2bi ; : stat>type ( stat -- type ) From b2a430629b2121fd764031d36f7a8b92001fb51d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 26 Mar 2008 14:55:04 -0500 Subject: [PATCH 202/886] fix wordpad --- extra/editors/editors.factor | 7 ++++--- extra/editors/wordpad/wordpad.factor | 4 ++-- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index 67e515ebc1..bfbfe1b6ca 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -1,8 +1,9 @@ -! 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 ; +io prettyprint source-files assocs vocabs vocabs.loader +io.backend splitting ; IN: editors TUPLE: no-edit-hook ; @@ -25,7 +26,7 @@ SYMBOL: edit-hook require ; : edit-location ( file line -- ) - >r current-directory get prepend-path r> + >r normalize-pathname "\\\\?\\" ?head drop r> edit-hook get [ call ] [ no-edit-hook edit-location ] if* ; : edit ( defspec -- ) diff --git a/extra/editors/wordpad/wordpad.factor b/extra/editors/wordpad/wordpad.factor index d1f979e0f3..3f3dd6cab1 100755 --- a/extra/editors/wordpad/wordpad.factor +++ b/extra/editors/wordpad/wordpad.factor @@ -5,10 +5,10 @@ IN: editors.wordpad : wordpad-path ( -- path ) \ wordpad-path get [ - program-files "\\Windows NT\\Accessories\\wordpad.exe" append-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 From 8939dd49718c6573e674fb5d7e1914f05ec8b137 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 26 Mar 2008 14:57:35 -0500 Subject: [PATCH 203/886] add path-separator --- core/io/files/files.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 60943be48c..48098e612d 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -45,6 +45,8 @@ HOOK: (file-appender) io-backend ( path -- stream ) ! Pathnames : path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ; +: path-separator ( -- string ) windows? "\\" "/" ? ; + : right-trim-separators ( str -- newstr ) [ path-separator? ] right-trim ; From eed26edf23777bdf445316a9258294ca1b4f1452 Mon Sep 17 00:00:00 2001 From: erg Date: Wed, 26 Mar 2008 15:24:54 -0500 Subject: [PATCH 204/886] fix bootstrap --- core/io/files/files-tests.factor | 10 ++++++---- core/io/files/files.factor | 18 +++++++++--------- extra/ui/freetype/freetype.factor | 2 +- 3 files changed, 16 insertions(+), 14 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index e3765fead0..7af1b602d0 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -178,10 +178,10 @@ io.files.unique sequences strings accessors ; [ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test [ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test -[ "foo/" ] [ "foo/bar/." parent-directory ] unit-test -[ "foo/" ] [ "foo/bar/./" parent-directory ] unit-test -[ "foo/" ] [ "foo/bar/baz/.." parent-directory ] unit-test -[ "foo/" ] [ "foo/bar/baz/../" parent-directory ] 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 @@ -190,6 +190,8 @@ io.files.unique sequences strings accessors ; [ "../../" 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 diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 8595f227bf..6500bdb387 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -66,14 +66,12 @@ ERROR: no-parent-directory path ; right-trim-separators dup last-path-separator [ 1+ cut - { - { "." [ 1 head* parent-directory ] } - { ".." [ - 2 head* parent-directory parent-directory - ] } - [ drop ] - } case - ] [ no-parent-directory ] if + ] [ + drop "." swap + ] if + { "" "." ".." } member? [ + no-parent-directory + ] when ] unless ; Date: Wed, 26 Mar 2008 15:25:20 -0500 Subject: [PATCH 205/886] remove a unit test --- extra/io/unix/files/files-tests.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor index 98de09e8f1..22b29b7a51 100755 --- a/extra/io/unix/files/files-tests.factor +++ b/extra/io/unix/files/files-tests.factor @@ -6,7 +6,6 @@ IN: io.unix.files.tests [ "/" ] [ "/etc/" parent-directory ] unit-test [ "/" ] [ "/etc" parent-directory ] unit-test [ "/" ] [ "/" parent-directory ] unit-test -[ "asdf" parent-directory ] must-fail [ f ] [ "" root-directory? ] unit-test [ t ] [ "/" root-directory? ] unit-test From 65a12660a73f23e98920377b9e959d8dd1a34627 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 26 Mar 2008 15:55:55 -0500 Subject: [PATCH 206/886] implement priorities on windows --- extra/io/launcher/launcher.factor | 1 + extra/io/unix/launcher/launcher.factor | 1 + extra/io/windows/launcher/launcher.factor | 12 ++++++++++++ extra/windows/kernel32/kernel32.factor | 1 - 4 files changed, 14 insertions(+), 1 deletion(-) diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index ac8dc15661..79382091ab 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -38,6 +38,7 @@ SYMBOL: +low-priority+ SYMBOL: +normal-priority+ SYMBOL: +high-priority+ SYMBOL: +highest-priority+ +SYMBOL: +realtime-priority+ : ( -- process ) process construct-empty diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index e16ecde6fa..11c608c68f 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -24,6 +24,7 @@ USE: unix { +normal-priority+ 0 } { +high-priority+ -10 } { +highest-priority+ -20 } + { +realtime-priority+ -20 } } at set-priority ] when* ; diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index ca8f5f3e59..2d281d0fe8 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -49,6 +49,17 @@ TUPLE: CreateProcess-args : 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 @@ -71,6 +82,7 @@ TUPLE: CreateProcess-args 0 pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when pick detached>> winnt? and [ DETACHED_PROCESS bitor ] when + pick lookup-priority [ bitor ] when* >>dwCreateFlags ; : fill-lpEnvironment ( process args -- process args ) diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 22a86818cf..ec70b14e68 100644 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -125,7 +125,6 @@ TYPEDEF: FILE_NOTIFY_INFORMATION* PFILE_NOTIFY_INFORMATION : OF_REOPEN 32768 ; : OF_VERIFY 1024 ; - : INFINITE HEX: FFFFFFFF ; inline ! From C:\cygwin\usr\include\w32api\winbase.h From 603a55bde5c20ccbf318c01fe1c849a95c841a0d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 26 Mar 2008 15:59:11 -0500 Subject: [PATCH 207/886] run deploy as +low-priority+ --- extra/tools/deploy/backend/backend.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 172a80b612..b019326ed5 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -21,6 +21,7 @@ IN: tools.deploy.backend swap >>command +stdout+ >>stderr +closed+ >>stdin + +low-priority+ >>priority utf8 dup copy-lines process>> wait-for-process zero? [ From d4dd93e3168182ad05c1b94a1c74eac90ed95a3c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 26 Mar 2008 16:22:34 -0500 Subject: [PATCH 208/886] move some io files unit tests to unix --- core/io/files/files-tests.factor | 8 -------- extra/io/unix/files/files-tests.factor | 10 ++++++++++ 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 7af1b602d0..36b32ea34c 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -10,8 +10,6 @@ io.files.unique sequences strings accessors ; [ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test [ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test [ "" ] [ "" file-name ] unit-test -[ "/" ] [ "/" file-name ] unit-test -[ "///" ] [ "///" file-name ] unit-test [ ] [ { "Hello world." } @@ -156,18 +154,12 @@ io.files.unique sequences strings accessors ; [ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test [ "/lib" ] [ "/usr" "../lib" append-path ] unit-test [ "/lib/" ] [ "/usr" "../lib/" append-path ] unit-test -[ "/lib" ] [ "/" "../lib" append-path ] unit-test -[ "/lib/" ] [ "/" "../lib/" append-path ] unit-test [ "" ] [ "" "." append-path ] unit-test [ "" ".." append-path ] must-fail [ "/" ] [ "/" "./." append-path ] unit-test [ "/" ] [ "/" "././" append-path ] unit-test -[ "/" ] [ "/" "../.." append-path ] unit-test -[ "/" ] [ "/" "../../" append-path ] unit-test -[ "/lib" ] [ "/" "../../lib" append-path ] unit-test -[ "/lib/" ] [ "/" "../../lib/" 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 diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor index 22b29b7a51..bb2039adfb 100755 --- a/extra/io/unix/files/files-tests.factor +++ b/extra/io/unix/files/files-tests.factor @@ -11,3 +11,13 @@ IN: io.unix.files.tests [ 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 From 4844bae31a36bba5193d863c61b3b50514efe4db Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Mar 2008 16:38:31 -0500 Subject: [PATCH 209/886] Tuple redefinition fixes --- core/tuples/tuples-tests.factor | 152 +++++++++++++++++--------------- core/tuples/tuples.factor | 91 ++++++++++--------- 2 files changed, 132 insertions(+), 111 deletions(-) diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index fec3bdbc6f..322974c3fd 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -2,18 +2,18 @@ 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 ; +strings compiler.units accessors ; IN: tuples.tests TUPLE: rect x y w h ; : rect construct-boa ; -: move ( x rect -- ) - [ rect-x + ] keep set-rect-x ; +: move ( x rect -- rect ) + [ + ] change-x ; -[ f ] [ 10 20 30 40 dup clone 5 swap [ move ] keep = ] unit-test +[ f ] [ 10 20 30 40 dup clone 5 swap move = ] unit-test -[ t ] [ 10 20 30 40 dup clone 0 swap [ move ] keep = ] unit-test +[ t ] [ 10 20 30 40 dup clone 0 swap move = ] unit-test GENERIC: delegation-test M: object delegation-test drop 3 ; @@ -34,27 +34,46 @@ TUPLE: quuux-tuple-2 ; [ 4 ] [ delegation-test-2 ] unit-test +! Make sure we handle tuple class redefinition +TUPLE: redefinition-test ; + +C: redefinition-test + + "redefinition-test" set + +[ t ] [ "redefinition-test" get redefinition-test? ] unit-test + +"IN: tuples.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 -100 200 "p" set +[ ] [ 100 200 "p" set ] unit-test ! Use eval to sequence parsing explicitly -"IN: tuples.tests TUPLE: point x y z ;" eval +[ ] [ "IN: tuples.tests TUPLE: point x y z ;" eval ] unit-test -[ 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 +[ 100 ] [ "p" get x>> ] unit-test +[ 200 ] [ "p" get y>> ] unit-test +[ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test -300 "p" get "set-point-z" "tuples.tests" lookup execute +"p" get 300 ">>z" "accessors" lookup execute drop + +[ 4 ] [ "p" get tuple-size ] unit-test + +[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test "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 +[ 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 ; @@ -68,10 +87,10 @@ PREDICATE: tuple silly-pred class \ rect = ; GENERIC: area -M: silly-pred area dup rect-w swap rect-h * ; +M: silly-pred area dup w>> swap h>> * ; TUPLE: circle radius ; -M: circle area circle-radius sq pi * ; +M: circle area radius>> sq pi * ; [ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test @@ -88,7 +107,7 @@ TUPLE: delegate-clone ; [ T{ delegate-clone T{ empty f } } clone ] unit-test ! Compiler regression -[ t length ] [ no-method-object t eq? ] must-fail-with +[ t length ] [ object>> t eq? ] must-fail-with [ "" ] [ "TUPLE: constructor-test ; C: constructor-test" eval word word-name ] unit-test @@ -96,7 +115,7 @@ TUPLE: delegate-clone ; TUPLE: size-test a b c d ; [ t ] [ - T{ size-test } array-capacity + T{ size-test } tuple-size size-test tuple-size = ] unit-test @@ -213,55 +232,50 @@ C: erg's-reshape-problem ! 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" eval -] [ [ no-tuple-class? ] 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 +! "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 tuple-size "a" get tuple-size = ] unit-test +! +! [ +! "IN: tuples.tests SYMBOL: not-a-class C: not-a-class" eval +! ] [ [ no-tuple-class? ] 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 diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 56fb12fffc..84b4f2eae5 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -3,7 +3,7 @@ USING: arrays definitions hashtables kernel kernel.private math namespaces sequences sequences.private strings vectors words quotations memory combinators generic -classes classes.private slots slots.deprecated slots.private +classes classes.private slots.deprecated slots.private slots compiler.units ; IN: tuples @@ -49,43 +49,6 @@ PRIVATE> 2drop f ] if ; -: 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 ; - M: tuple-class tuple-layout "layout" word-prop ; : define-tuple-predicate ( class -- ) @@ -114,15 +77,59 @@ M: tuple-class tuple-layout "layout" word-prop ; dup "slot-names" word-prop length 1+ { } 0 "layout" set-word-prop ; -PRIVATE> +: removed-slots ( class newslots -- seq ) + swap "slot-names" word-prop seq-diff ; -: define-tuple-class ( class slots -- ) - 2dup check-shape - over f tuple tuple-class define-class +: forget-slots ( class newslots -- ) + dupd removed-slots [ + 2dup + reader-word forget-method + writer-word forget-method + ] with each ; + +: 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 ; + +: tuple-class-unchanged 2drop ; + +: prepare-tuple-class ( class slots -- ) dupd define-tuple-slots dup define-tuple-layout define-tuple-predicate ; +: redefine-tuple-class ( class slots -- ) + 2dup forget-slots + 2dup reshape-tuples + over changed-word + over redefined + prepare-tuple-class ; + +: define-new-tuple-class ( class slots -- ) + over f tuple tuple-class define-class + prepare-tuple-class ; + +PRIVATE> + +: define-tuple-class ( class slots -- ) + { + { [ over tuple-class? not ] [ define-new-tuple-class ] } + { [ over "slot-names" word-prop over = ] [ tuple-class-unchanged ] } + { [ t ] [ redefine-tuple-class ] } + } cond ; + M: tuple clone (clone) dup delegate clone over set-delegate ; From 89a531d4a2ba2a5c6e95978bfac0e72ebedd605d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Mar 2008 17:07:50 -0500 Subject: [PATCH 210/886] Fixing unit tests --- core/bootstrap/primitives.factor | 12 +++- core/io/encodings/encodings-tests.factor | 8 +-- core/io/io-tests.factor | 8 +-- core/parser/parser.factor | 8 +++ core/syntax/syntax.factor | 8 +-- core/tuples/tuples-tests.factor | 92 ++++++++++++------------ core/tuples/tuples.factor | 18 +++-- extra/combinators/lib/lib.factor | 33 ++++----- extra/io/encodings/8-bit/8-bit.factor | 6 +- extra/openssl/openssl-tests.factor | 10 +-- 10 files changed, 110 insertions(+), 93 deletions(-) mode change 100644 => 100755 extra/io/encodings/8-bit/8-bit.factor diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 253f23238a..3f6fedb40c 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -358,7 +358,9 @@ builtins get num-tags get tail f union-class define-class "null" "kernel" create { } f union-class define-class ! Create special tombstone values -"tombstone" "hashtables.private" create { } define-tuple-class +"tombstone" "hashtables.private" create +"tuple" "kernel" lookup +{ } define-tuple-class "((empty))" "hashtables.private" create "tombstone" "hashtables.private" lookup f @@ -370,6 +372,7 @@ builtins get num-tags get tail f union-class define-class ! Some tuple classes "hashtable" "hashtables" create +"tuple" "kernel" lookup { { { "array-capacity" "sequences.private" } @@ -390,6 +393,7 @@ builtins get num-tags get tail f union-class define-class } define-tuple-class "sbuf" "sbufs" create +"tuple" "kernel" lookup { { { "string" "strings" } @@ -405,6 +409,7 @@ builtins get num-tags get tail f union-class define-class } define-tuple-class "vector" "vectors" create +"tuple" "kernel" lookup { { { "array" "arrays" } @@ -420,6 +425,7 @@ builtins get num-tags get tail f union-class define-class } define-tuple-class "byte-vector" "byte-vectors" create +"tuple" "kernel" lookup { { { "byte-array" "byte-arrays" } @@ -435,6 +441,7 @@ builtins get num-tags get tail f union-class define-class } define-tuple-class "bit-vector" "bit-vectors" create +"tuple" "kernel" lookup { { { "bit-array" "bit-arrays" } @@ -450,6 +457,7 @@ builtins get num-tags get tail f union-class define-class } define-tuple-class "float-vector" "float-vectors" create +"tuple" "kernel" lookup { { { "float-array" "float-arrays" } @@ -465,6 +473,7 @@ builtins get num-tags get tail f union-class define-class } define-tuple-class "curry" "kernel" create +"tuple" "kernel" lookup { { { "object" "kernel" } @@ -484,6 +493,7 @@ dup f "inline" set-word-prop dup tuple-layout [ ] curry define "compose" "kernel" create +"tuple" "kernel" lookup { { { "object" "kernel" } diff --git a/core/io/encodings/encodings-tests.factor b/core/io/encodings/encodings-tests.factor index 73d2efa7d4..397d1ea89c 100755 --- a/core/io/encodings/encodings-tests.factor +++ b/core/io/encodings/encodings-tests.factor @@ -6,7 +6,7 @@ IN: io.streams.encodings.tests resource-path ascii ; [ { } ] -[ "/core/io/test/empty-file.txt" lines ] +[ "core/io/test/empty-file.txt" lines ] unit-test : lines-test ( stream -- line1 line2 ) @@ -16,21 +16,21 @@ unit-test "This is a line." "This is another line." ] [ - "/core/io/test/windows-eol.txt" lines-test + "core/io/test/windows-eol.txt" lines-test ] unit-test [ "This is a line." "This is another line." ] [ - "/core/io/test/mac-os-eol.txt" lines-test + "core/io/test/mac-os-eol.txt" lines-test ] unit-test [ "This is a line." "This is another line." ] [ - "/core/io/test/unix-eol.txt" lines-test + "core/io/test/unix-eol.txt" lines-test ] unit-test [ diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 91e51f25b0..6662ac41d7 100755 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -4,7 +4,7 @@ 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 @@ -14,14 +14,14 @@ IN: io.tests [ "This is a line.\rThis is another line.\r" ] [ - "/core/io/test/mac-os-eol.txt" + "core/io/test/mac-os-eol.txt" [ 500 read ] with-stream ] unit-test [ 255 ] [ - "/core/io/test/binary.txt" + "core/io/test/binary.txt" [ read1 ] with-stream >fixnum ] unit-test @@ -36,7 +36,7 @@ IN: io.tests } ] [ [ - "/core/io/test/separator-test.txt" [ + "core/io/test/separator-test.txt" [ "J" read-until 2array , "i" read-until 2array , "X" read-until 2array , diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 28822db708..0a00c742a0 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -288,6 +288,14 @@ M: no-word summary : CREATE-METHOD ( -- method ) scan-word bootstrap-word scan-word create-method-in ; +: parse-tuple-definition ( -- class superclass slots ) + CREATE-CLASS + scan { + { ";" [ tuple f ] } + { "<" [ scan-word ";" parse-tokens ] } + [ >r tuple ";" parse-tokens r> add* ] + } case ; + ERROR: staging-violation word ; M: staging-violation summary diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 843f372542..17b3b86269 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -154,7 +154,7 @@ IN: bootstrap.syntax ] define-syntax "TUPLE:" [ - CREATE-CLASS ";" parse-tokens define-tuple-class + parse-tuple-definition define-tuple-class ] define-syntax "C:" [ @@ -164,9 +164,9 @@ IN: bootstrap.syntax ] define-syntax "ERROR:" [ - CREATE-CLASS dup ";" parse-tokens define-tuple-class - dup save-location - dup [ construct-boa throw ] curry define + parse-tuple-definition + pick save-location + define-error-class ] define-syntax "FORGET:" [ diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index 322974c3fd..702557e257 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -233,49 +233,49 @@ C: erg's-reshape-problem : cons-test-1 \ erg's-reshape-problem construct-empty ; : cons-test-2 \ erg's-reshape-problem construct-boa ; -! "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 tuple-size "a" get tuple-size = ] unit-test -! -! [ -! "IN: tuples.tests SYMBOL: not-a-class C: not-a-class" eval -! ] [ [ no-tuple-class? ] 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 +"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 tuple-size "a" get tuple-size = ] unit-test + +[ + "IN: tuples.tests SYMBOL: not-a-class C: not-a-class" eval +] [ [ no-tuple-class? ] 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 diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 84b4f2eae5..8318c0ede1 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -103,33 +103,39 @@ M: tuple-class tuple-layout "layout" word-prop ; become ] 2curry after-compilation ; -: tuple-class-unchanged 2drop ; +: tuple-class-unchanged ( class superclass slots -- ) 3drop ; : prepare-tuple-class ( class slots -- ) dupd define-tuple-slots dup define-tuple-layout define-tuple-predicate ; -: redefine-tuple-class ( class slots -- ) +: redefine-tuple-class ( class superclass slots -- ) + nip 2dup forget-slots 2dup reshape-tuples over changed-word over redefined prepare-tuple-class ; -: define-new-tuple-class ( class slots -- ) +: define-new-tuple-class ( class superclass slots -- ) + nip over f tuple tuple-class define-class prepare-tuple-class ; PRIVATE> -: define-tuple-class ( class slots -- ) +: define-tuple-class ( class superclass slots -- ) { - { [ over tuple-class? not ] [ define-new-tuple-class ] } - { [ over "slot-names" word-prop over = ] [ tuple-class-unchanged ] } + { [ pick tuple-class? not ] [ define-new-tuple-class ] } + { [ pick "slot-names" word-prop over = ] [ tuple-class-unchanged ] } { [ t ] [ redefine-tuple-class ] } } cond ; +: define-error-class ( class superclass slots -- ) + pick >r define-tuple-class r> + dup [ construct-boa throw ] curry define ; + M: tuple clone (clone) dup delegate clone over set-delegate ; diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 459938c885..9fe19555c5 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -1,7 +1,8 @@ -! 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 ; @@ -34,9 +35,8 @@ MACRO: nwith ( quot n -- ) 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 @@ -88,26 +88,21 @@ 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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor old mode 100644 new mode 100755 index 2cc6b2e57c..ec75dc600a --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -54,10 +54,8 @@ IN: io.encodings.8-bit [ byte>ch ] [ ch>byte ] bi ; : empty-tuple-class ( string -- class ) - in get create - dup { f } "slots" set-word-prop - dup predicate-word drop - dup { } define-tuple-class ; + "io.encodings.8-bit" create + dup tuple { } define-tuple-class ; : data-quot ( class word data -- quot ) >r [ word-name ] 2apply "/" swap 3append diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor index 2d0f5bb5d0..c689f729d1 100755 --- a/extra/openssl/openssl-tests.factor +++ b/extra/openssl/openssl-tests.factor @@ -25,7 +25,7 @@ namespaces math math.parser openssl prettyprint sequences tools.test ; [ ] [ 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 @@ -33,10 +33,10 @@ namespaces math math.parser openssl prettyprint sequences tools.test ; [ ] [ get-ctx "password" string>char-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 @@ -45,7 +45,7 @@ verify-load-locations ] 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 @@ -129,7 +129,7 @@ verify-load-locations ] 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 From 85a3ee3e5bfe49f316a01140592d9ac174decf6e Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 26 Mar 2008 16:43:03 +1300 Subject: [PATCH 211/886] Remove memoization in 'compile' word in pegs This creates issues when recompiling a an existing EBNF parser for reasons I've not yet tracked down. Disabling it slows things down but makes things work correctly till I investigate the issue. --- extra/peg/peg.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 00271a9ad3..e9477dc408 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -28,7 +28,7 @@ GENERIC: (compile) ( parser -- quot ) [ swap compiled-parsers get set-at ] keep ] if* ; -MEMO: compile ( parser -- word ) +: compile ( parser -- word ) H{ } clone compiled-parsers [ [ compiled-parser ] with-compilation-unit ] with-variable ; From c793a381fe651b9d09e0b5689c20703de546aca2 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 26 Mar 2008 17:38:30 +1300 Subject: [PATCH 212/886] Add hook for packrat implementation --- extra/peg/peg.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index e9477dc408..af26f888f1 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -17,6 +17,12 @@ SYMBOL: compiled-parsers GENERIC: (compile) ( parser -- quot ) +: run-parser ( input quot -- result ) + #! Eventually this will be replaced with something that + #! can do packrat parsing by memoizing the results of + #! a parser. For now, it just calls the quotation. + call ; inline + : compiled-parser ( parser -- word ) #! Look to see if the given parser has been compiled. #! If not, compile it to a temporary word, cache it, @@ -24,7 +30,7 @@ GENERIC: (compile) ( parser -- quot ) dup compiled-parsers get at [ nip ] [ - dup (compile) define-temp + dup (compile) [ run-parser ] curry define-temp [ swap compiled-parsers get set-at ] keep ] if* ; From bd33e2fef9e77195aefa384639978b33179aab45 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 27 Mar 2008 11:23:19 +1300 Subject: [PATCH 213/886] Fix cache to handle the case of 'f' being a valid cached value --- core/assocs/assocs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index ff0938e001..196ec614b7 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -134,11 +134,11 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) (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 From 690621ffb653807c68457b5caf83933a38fb207e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Mar 2008 18:23:19 -0500 Subject: [PATCH 214/886] Change PREDICATE: syntax --- core/alien/alien.factor | 4 +- core/arrays/arrays.factor | 2 +- core/classes/algebra/algebra-docs.factor | 6 +- core/classes/algebra/algebra-tests.factor | 2 +- core/classes/classes-tests.factor | 2 +- core/classes/classes.factor | 8 +-- core/classes/mixin/mixin.factor | 2 +- core/classes/predicate/predicate-docs.factor | 2 +- core/classes/predicate/predicate.factor | 8 +-- core/classes/union/union.factor | 2 +- core/cpu/architecture/architecture.factor | 6 +- core/cpu/arm/assembler/assembler.factor | 2 +- core/cpu/x86/32/32.factor | 2 +- core/cpu/x86/64/64.factor | 2 +- core/cpu/x86/assembler/assembler.factor | 24 +++++--- core/debugger/debugger.factor | 2 +- core/generic/generic-tests.factor | 2 +- core/generic/generic.factor | 7 ++- core/generic/math/math.factor | 4 +- core/generic/standard/standard.factor | 6 +- core/inference/dataflow/dataflow.factor | 6 +- core/parser/parser-tests.factor | 2 +- core/parser/parser.factor | 2 +- core/prettyprint/prettyprint-tests.factor | 6 ++ core/prettyprint/prettyprint.factor | 3 +- core/sequences/sequences.factor | 2 +- core/slots/deprecated/deprecated.factor | 4 +- core/syntax/syntax-docs.factor | 10 ++- core/syntax/syntax.factor | 5 +- core/tuples/tuples-docs.factor | 10 +-- core/tuples/tuples-tests.factor | 65 ++++++++++++++++++-- core/tuples/tuples.factor | 8 ++- core/words/words.factor | 6 +- extra/delegate/delegate.factor | 2 +- extra/help/markup/markup.factor | 2 +- extra/help/topics/topics.factor | 2 +- extra/inverse/inverse.factor | 6 +- extra/io/nonblocking/nonblocking.factor | 4 +- extra/locals/locals.factor | 14 ++--- extra/macros/macros.factor | 2 +- extra/memoize/memoize.factor | 2 +- extra/multi-methods/multi-methods.factor | 11 ++-- extra/opengl/shaders/shaders.factor | 8 +-- extra/singleton/singleton.factor | 5 +- extra/ui/commands/commands.factor | 2 +- extra/ui/operations/operations.factor | 2 +- extra/unicode/syntax/syntax.factor | 2 +- extra/xml-rpc/xml-rpc.factor | 2 +- extra/xml/data/data.factor | 4 +- 49 files changed, 184 insertions(+), 110 deletions(-) mode change 100644 => 100755 core/arrays/arrays.factor mode change 100644 => 100755 extra/ui/operations/operations.factor mode change 100644 => 100755 extra/xml-rpc/xml-rpc.factor mode change 100644 => 100755 extra/xml/data/data.factor diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 436d73e874..777bf523a5 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -7,7 +7,7 @@ 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 @@ -18,7 +18,7 @@ alien POSTPONE: f byte-array bit-array float-array ; DEFER: pinned-c-ptr? -PREDICATE: alien pinned-alien +PREDICATE: pinned-alien < alien underlying-alien pinned-c-ptr? ; UNION: pinned-c-ptr diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor old mode 100644 new mode 100755 index 714973e7ca..414c64581e --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -31,4 +31,4 @@ INSTANCE: array sequence : 4array ( w x y z -- array ) { } 4sequence ; flushable -PREDICATE: array pair length 2 number= ; +PREDICATE: pair < array length 2 number= ; diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor index c21098916d..632af1d040 100755 --- a/core/classes/algebra/algebra-docs.factor +++ b/core/classes/algebra/algebra-docs.factor @@ -39,15 +39,15 @@ HELP: sort-classes { $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ; HELP: class-or -{ $values { "class1" class } { "class2" class } { "class" class } } +{ $values { "first" class } { "second" class } { "class" class } } { $description "Outputs the smallest anonymous class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ; HELP: class-and -{ $values { "class1" class } { "class2" class } { "class" class } } +{ $values { "first" class } { "second" class } { "class" class } } { $description "Outputs the largest anonymous class contained in both " { $snippet "class1" } " and " { $snippet "class2" } "." } ; HELP: classes-intersect? -{ $values { "class1" class } { "class2" class } { "?" "a boolean" } } +{ $values { "first" class } { "second" 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 diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 24a18559fe..cdf817e31d 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -51,7 +51,7 @@ UNION: both first-one union-class ; [ f ] [ \ reversed \ slice class< ] unit-test [ f ] [ \ slice \ reversed class< ] unit-test -PREDICATE: word no-docs "documentation" word-prop not ; +PREDICATE: no-docs < word "documentation" word-prop not ; UNION: no-docs-union no-docs integer ; diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 8f43aa3336..ae9e6ec154 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -28,7 +28,7 @@ M: union-1 generic-update-test drop "union-1" ; [ f ] [ union-1 number class< ] unit-test [ "union-1" ] [ { 1.0 } generic-update-test ] 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 diff --git a/core/classes/classes.factor b/core/classes/classes.factor index b6082ad334..c2c19836cd 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -25,15 +25,15 @@ SYMBOL: class-or-cache class-and-cache get clear-assoc class-or-cache get clear-assoc ; -PREDICATE: word class ( obj -- ? ) "class" word-prop ; +PREDICATE: class < word ( obj -- ? ) "class" word-prop ; SYMBOL: update-map SYMBOL: builtins -PREDICATE: class builtin-class +PREDICATE: builtin-class < class "metaclass" word-prop builtin-class eq? ; -PREDICATE: class tuple-class +PREDICATE: tuple-class < class "metaclass" word-prop tuple-class eq? ; : classes ( -- seq ) all-words [ class? ] subset ; @@ -47,7 +47,7 @@ PREDICATE: class tuple-class : predicate-effect 1 { "?" } ; -PREDICATE: word predicate "predicating" word-prop >boolean ; +PREDICATE: predicate < word "predicating" word-prop >boolean ; : define-predicate ( class quot -- ) >r "predicate" word-prop first diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index f9b987eb78..780f76f0f8 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -4,7 +4,7 @@ USING: classes classes.union words kernel sequences definitions combinators arrays ; 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 ; diff --git a/core/classes/predicate/predicate-docs.factor b/core/classes/predicate/predicate-docs.factor index a65392773d..d03d97cd4c 100755 --- a/core/classes/predicate/predicate-docs.factor +++ b/core/classes/predicate/predicate-docs.factor @@ -14,7 +14,7 @@ ARTICLE: "predicates" "Predicate classes" 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" } ; diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index 6d1c727ee2..9f5961895a 100755 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -1,9 +1,9 @@ -! 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 ) @@ -13,8 +13,8 @@ PREDICATE: class predicate-class "predicate-definition" word-prop , [ drop f ] , \ if , ] [ ] make ; -: define-predicate-class ( superclass class definition -- ) - >r dup f roll predicate-class define-class r> +: define-predicate-class ( class superclass definition -- ) + >r >r dup f r> predicate-class define-class r> dupd "predicate-definition" set-word-prop dup predicate-quot define-predicate ; diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index c1c82d158b..3a791c22d0 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -4,7 +4,7 @@ USING: words sequences kernel assocs combinators classes generic.standard 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. diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index cd6c8b61f7..8d1e1f281f 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -153,11 +153,11 @@ M: f v>operand drop \ f tag-number ; 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 diff --git a/core/cpu/arm/assembler/assembler.factor b/core/cpu/arm/assembler/assembler.factor index d10b24de4e..5a69f93d85 100755 --- a/core/cpu/arm/assembler/assembler.factor +++ b/core/cpu/arm/assembler/assembler.factor @@ -27,7 +27,7 @@ SYMBOL: R15 { 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 ; diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 81a7d7cd02..f4af421cdd 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -8,7 +8,7 @@ alien.compiler combinators command-line compiler compiler.units io vocabs.loader accessors ; IN: cpu.x86.32 -PREDICATE: x86-backend x86-32-backend +PREDICATE: x86-32-backend < x86-backend x86-backend-cell 4 = ; ! We implement the FFI for Linux, OS X and Windows all at once. diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 25e32225d4..c2af60e983 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -8,7 +8,7 @@ layouts alien alien.accessors alien.compiler alien.structs slots splitting assocs ; IN: cpu.x86.64 -PREDICATE: x86-backend amd64-backend +PREDICATE: amd64-backend < x86-backend x86-backend-cell 8 = ; M: amd64-backend ds-reg R14 ; diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index 65caec412e..796388ffe1 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -52,13 +52,23 @@ GENERIC: extended? ( op -- ? ) 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 > ; @@ -285,7 +295,7 @@ GENERIC: (MOV-I) ( src dst -- ) 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) ; diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 4775093ba7..3361073d35 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -156,7 +156,7 @@ M: relative-overflow summary : 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 ] } diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 853a03d184..6a7f8f29fc 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -44,7 +44,7 @@ M: object funny drop 0 ; [ 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 ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 36ca0358b7..131b7e57c9 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -19,7 +19,8 @@ M: object perform-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 ; @@ -30,7 +31,7 @@ M: generic definition drop f ; : 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 ) @@ -55,7 +56,7 @@ TUPLE: check-method class generic ; : 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 diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 93c89af25c..85bd736139 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -5,7 +5,7 @@ math namespaces sequences words quotations layouts combinators sequences.private classes classes.algebra definitions ; IN: generic.math -PREDICATE: class math-class ( object -- ? ) +PREDICATE: math-class < class dup null bootstrap-word eq? [ drop f ] [ @@ -79,7 +79,7 @@ M: math-combination perform-combination ] if nip ] math-vtable nip ; -PREDICATE: generic math-generic ( word -- ? ) +PREDICATE: math-generic < generic ( word -- ? ) "combination" word-prop math-combination? ; M: math-generic definer drop \ MATH: f ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 4105a05cb1..4447c5a264 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -174,13 +174,13 @@ M: hook-combination perform-combination : define-simple-generic ( word -- ) T{ standard-combination f 0 } define-generic ; -PREDICATE: generic standard-generic +PREDICATE: standard-generic < generic "combination" word-prop standard-combination? ; -PREDICATE: standard-generic simple-generic +PREDICATE: simple-generic < standard-generic "combination" word-prop standard-combination-# zero? ; -PREDICATE: generic hook-generic +PREDICATE: hook-generic < generic "combination" word-prop hook-combination? ; GENERIC: dispatch# ( word -- n ) diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 23b5343c9c..0b6cf04028 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -102,7 +102,7 @@ TUPLE: #label word loop? ; : #label ( word label -- node ) \ #label param-node [ set-#label-word ] keep ; -PREDICATE: #label #loop #label-loop? ; +PREDICATE: #loop < #label #label-loop? ; TUPLE: #entry ; @@ -309,9 +309,9 @@ SYMBOL: node-stack 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 ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index f024eda54c..670740fff0 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -389,7 +389,7 @@ IN: parser.tests ] 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 ] [ diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 0a00c742a0..bb3ad254da 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -214,7 +214,7 @@ SYMBOL: in ERROR: unexpected want got ; -PREDICATE: unexpected unexpected-eof +PREDICATE: unexpected-eof < unexpected unexpected-got not ; : unexpected-eof ( word -- * ) f unexpected ; diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 8df97effb6..35b30ac46f 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -329,3 +329,9 @@ M: f generic-see-test-with-f ; [ "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 diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 8bce81650f..26c6076769 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -247,8 +247,9 @@ M: mixin-class see-class* M: predicate-class see-class* block> ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 14674ba2f2..111cf74ea2 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -60,7 +60,7 @@ INSTANCE: immutable-sequence sequence #! 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 ) diff --git a/core/slots/deprecated/deprecated.factor b/core/slots/deprecated/deprecated.factor index cc93aeeff2..2ec8f3d0d1 100755 --- a/core/slots/deprecated/deprecated.factor +++ b/core/slots/deprecated/deprecated.factor @@ -8,7 +8,7 @@ IN: slots.deprecated : reader-effect ( class spec -- effect ) >r ?word-name 1array r> slot-spec-name 1array ; -PREDICATE: word slot-reader "reading" word-prop >boolean ; +PREDICATE: slot-reader < word "reading" word-prop >boolean ; : set-reader-props ( class spec -- ) 2dup reader-effect @@ -30,7 +30,7 @@ PREDICATE: word slot-reader "reading" word-prop >boolean ; : writer-effect ( class spec -- effect ) slot-spec-name swap ?word-name 2array 0 ; -PREDICATE: word slot-writer "writing" word-prop >boolean ; +PREDICATE: slot-writer < word "writing" word-prop >boolean ; : set-writer-props ( class spec -- ) 2dup writer-effect diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index c0ceb4119a..3874cecf71 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -543,8 +543,8 @@ HELP: INSTANCE: { $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 @@ -557,11 +557,9 @@ HELP: PREDICATE: } ; 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." -$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... ;" } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 17b3b86269..9190b9676d 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -6,7 +6,7 @@ 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 ; +combinators debugger ; IN: bootstrap.syntax ! These words are defined as a top-level form, instead of with @@ -148,8 +148,9 @@ IN: bootstrap.syntax ] define-syntax "PREDICATE:" [ - scan-word CREATE-CLASS + scan "<" assert= + scan-word parse-definition define-predicate-class ] define-syntax diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor index 427c7fbf60..6e0f319c9a 100755 --- a/core/tuples/tuples-docs.factor +++ b/core/tuples/tuples-docs.factor @@ -165,7 +165,7 @@ 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 +HELP: removed-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" } "." } ; @@ -190,8 +190,8 @@ HELP: define-tuple-predicate { $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" } } +HELP: redefine-tuple-class +{ $values { "class" class } { "superclass" 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." } @@ -214,8 +214,8 @@ HELP: check-tuple { $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: } "." } +{ $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" } ; diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index 702557e257..e7ad44a264 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -2,7 +2,8 @@ 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 accessors ; +strings compiler.units accessors classes.algebra calendar +prettyprint io.streams.string ; IN: tuples.tests TUPLE: rect x y w h ; @@ -83,7 +84,7 @@ C: predicate-test [ t ] [ predicate-test? ] unit-test -PREDICATE: tuple silly-pred +PREDICATE: silly-pred < tuple class \ rect = ; GENERIC: area @@ -243,6 +244,58 @@ C: erg's-reshape-problem "IN: tuples.tests SYMBOL: not-a-class C: not-a-class" eval ] [ [ no-tuple-class? ] is? ] must-fail-with +! Inheritance +TUPLE: computer cpu ram ; + +[ "IN: tuples.tests TUPLE: computer cpu ram ;\n" ] [ + [ \ computer see ] with-string-writer +] unit-test + +TUPLE: laptop < computer battery ; +C: 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" set ] unit-test +[ t ] [ "laptop" get laptop? ] unit-test +[ t ] [ "laptop" get computer? ] unit-test +[ t ] [ "laptop" get tuple? ] unit-test + +[ "IN: tuples.tests TUPLE: laptop < computer battery ;\n" ] [ + [ \ laptop see ] with-string-writer +] unit-test + +TUPLE: server < computer rackmount? ; +C: 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 + +[ ] [ "Pentium" 128 "1U" "server" set ] unit-test +[ t ] [ "server" get server? ] unit-test +[ t ] [ "server" get computer? ] unit-test +[ t ] [ "server" get tuple? ] unit-test + +[ 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 + +[ "IN: tuples.tests TUPLE: server < computer rackmount ;\n" ] [ + [ \ server see ] with-string-writer +] unit-test + +[ + "IN: tuples.tests TUPLE: bad-superclass < word ;" eval +] must-fail + ! Hardcore unit tests USE: threads @@ -250,14 +303,14 @@ USE: threads [ ] [ [ - \ thread { "xxx" } "slot-names" get append + \ thread tuple { "xxx" } "slot-names" get append define-tuple-class ] with-compilation-unit [ 1337 sleep ] "Test" spawn drop [ - \ thread "slot-names" get + \ thread tuple "slot-names" get define-tuple-class ] with-compilation-unit ] unit-test @@ -268,14 +321,14 @@ USE: vocabs [ ] [ [ - \ vocab { "xxx" } "slot-names" get append + \ vocab tuple { "xxx" } "slot-names" get append define-tuple-class ] with-compilation-unit all-words drop [ - \ vocab "slot-names" get + \ vocab tuple "slot-names" get define-tuple-class ] with-compilation-unit ] unit-test diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 8318c0ede1..83f398242a 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -110,8 +110,11 @@ M: tuple-class tuple-layout "layout" word-prop ; dup define-tuple-layout define-tuple-predicate ; +: change-superclass "not supported" throw ; + : redefine-tuple-class ( class superclass slots -- ) - nip + >r 2dup swap superclass eq? + [ drop ] [ dupd change-superclass ] if r> 2dup forget-slots 2dup reshape-tuples over changed-word @@ -119,8 +122,7 @@ M: tuple-class tuple-layout "layout" word-prop ; prepare-tuple-class ; : define-new-tuple-class ( class superclass slots -- ) - nip - over f tuple tuple-class define-class + >r dupd f swap tuple-class define-class r> prepare-tuple-class ; PRIVATE> diff --git a/core/words/words.factor b/core/words/words.factor index de253e6fee..5c0d84d4cc 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -23,17 +23,17 @@ M: word definition word-def ; ERROR: undefined ; -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 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 ; diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 67b8a39320..7f24d6258f 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -10,7 +10,7 @@ IN: delegate CREATE-WORD dup define-symbol parse-definition swap define-protocol ; parsing -PREDICATE: word protocol "protocol-words" word-prop ; +PREDICATE: protocol < word "protocol-words" word-prop ; GENERIC: group-words ( group -- words ) diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 9c3615f629..5dc7255eed 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -14,7 +14,7 @@ IN: help.markup ! 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 diff --git a/extra/help/topics/topics.factor b/extra/help/topics/topics.factor index 4a86d49a28..c12c392eb3 100755 --- a/extra/help/topics/topics.factor +++ b/extra/help/topics/topics.factor @@ -16,7 +16,7 @@ M: link >link ; M: vocab-spec >link ; M: object >link link construct-boa ; -PREDICATE: link word-link link-name word? ; +PREDICATE: word-link < link link-name word? ; M: link summary [ diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 4bb620083f..1468065ebe 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -54,9 +54,9 @@ M: no-inverse summary : 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 -- ) diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 8f5babeff7..ed98665e06 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -22,8 +22,8 @@ M: port set-timeout set-port-timeout ; SYMBOL: closed -PREDICATE: port input-port port-type input-port eq? ; -PREDICATE: port output-port port-type output-port eq? ; +PREDICATE: input-port < port port-type input-port eq? ; +PREDICATE: output-port < port port-type output-port eq? ; GENERIC: init-handle ( handle -- ) GENERIC: close-handle ( handle -- ) diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 640ae0c9ea..455f39d2b5 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -29,23 +29,23 @@ TUPLE: wlet bindings body ; C: wlet -PREDICATE: word local "local?" word-prop ; +PREDICATE: local < word "local?" word-prop ; : ( name -- word ) #! Create a local variable identifier f dup t "local?" set-word-prop ; -PREDICATE: word local-word "local-word?" word-prop ; +PREDICATE: local-word < word "local-word?" word-prop ; : ( name -- word ) f dup t "local-word?" set-word-prop ; -PREDICATE: word local-reader "local-reader?" word-prop ; +PREDICATE: local-reader < word "local-reader?" word-prop ; : ( name -- word ) f dup t "local-reader?" set-word-prop ; -PREDICATE: word local-writer "local-writer?" word-prop ; +PREDICATE: local-writer < word "local-writer?" word-prop ; : ( reader -- word ) dup word-name "!" append f @@ -357,7 +357,7 @@ 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 \ :: \ ; ; @@ -373,7 +373,7 @@ M: lambda-word definition 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:: \ ; ; @@ -383,7 +383,7 @@ M: lambda-macro definition 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:: \ ; ; diff --git a/extra/macros/macros.factor b/extra/macros/macros.factor index 87b3acd47c..b242f91d3b 100755 --- a/extra/macros/macros.factor +++ b/extra/macros/macros.factor @@ -17,7 +17,7 @@ IN: macros : MACRO: (:) define-macro ; parsing -PREDICATE: word macro "macro" word-prop >boolean ; +PREDICATE: macro < word "macro" word-prop >boolean ; M: macro definer drop \ MACRO: \ ; ; diff --git a/extra/memoize/memoize.factor b/extra/memoize/memoize.factor index ab915ae7d5..45ae2cc959 100755 --- a/extra/memoize/memoize.factor +++ b/extra/memoize/memoize.factor @@ -42,7 +42,7 @@ IN: memoize : 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 ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 42ade34186..ed82d2478e 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -64,7 +64,8 @@ GENERIC: method-prologue ( combination -- quot ) TUPLE: method word def classes generic loc ; -PREDICATE: word method-body "multi-method" word-prop >boolean ; +PREDICATE: method-body < word + "multi-method" word-prop >boolean ; M: method-body stack-effect "multi-method" word-prop method-generic stack-effect ; @@ -209,13 +210,13 @@ M: hook-combination generic-prologue USE: qualified QUALIFIED: syntax -PREDICATE: word generic +PREDICATE: generic < word "multi-combination" word-prop >boolean ; -PREDICATE: word standard-generic +PREDICATE: standard-generic < word "multi-combination" word-prop standard-combination? ; -PREDICATE: word hook-generic +PREDICATE: hook-generic < word "multi-combination" word-prop hook-combination? ; syntax:M: standard-generic definer drop \ GENERIC: f ; @@ -233,7 +234,7 @@ syntax:M: hook-generic synopsis* 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 diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor index 7403b7cb05..9d415d8394 100755 --- a/extra/opengl/shaders/shaders.factor +++ b/extra/opengl/shaders/shaders.factor @@ -55,9 +55,9 @@ IN: opengl.shaders : 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 @@ -126,7 +126,7 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ; MACRO: with-gl-program ( uniforms quot -- ) (make-with-gl-program) ; -PREDICATE: integer gl-program (gl-program?) ; +PREDICATE: gl-program < integer (gl-program?) ; : ( vertex-shader-source fragment-shader-source -- program ) >r check-gl-shader diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor index 0b77443a50..9ec9f2f4a3 100755 --- a/extra/singleton/singleton.factor +++ b/extra/singleton/singleton.factor @@ -5,8 +5,9 @@ sequences words ; IN: singleton : define-singleton ( token -- ) - \ word swap create-class-in - dup [ eq? ] curry define-predicate-class ; + create-class-in + \ word + over [ eq? ] curry define-predicate-class ; : SINGLETON: scan define-singleton ; parsing diff --git a/extra/ui/commands/commands.factor b/extra/ui/commands/commands.factor index dbb838a5c5..f73276bbe6 100755 --- a/extra/ui/commands/commands.factor +++ b/extra/ui/commands/commands.factor @@ -9,7 +9,7 @@ SYMBOL: +nullary+ SYMBOL: +listener+ SYMBOL: +description+ -PREDICATE: word listener-command +listener+ word-prop ; +PREDICATE: listener-command < word +listener+ word-prop ; GENERIC: invoke-command ( target command -- ) diff --git a/extra/ui/operations/operations.factor b/extra/ui/operations/operations.factor old mode 100644 new mode 100755 index 45cd7732c2..a9009e386e --- a/extra/ui/operations/operations.factor +++ b/extra/ui/operations/operations.factor @@ -19,7 +19,7 @@ TUPLE: operation predicate command translator hook listener? ; set-operation-hook } operation construct ; -PREDICATE: operation listener-operation +PREDICATE: listener-operation < operation dup operation-command listener-command? swap operation-listener? or ; diff --git a/extra/unicode/syntax/syntax.factor b/extra/unicode/syntax/syntax.factor index bd3fd4ae2a..4dc91a73c2 100755 --- a/extra/unicode/syntax/syntax.factor +++ b/extra/unicode/syntax/syntax.factor @@ -35,7 +35,7 @@ IN: unicode.syntax ] [ ] make ; : define-category ( word categories -- ) - [category] fixnum -rot define-predicate-class ; + [category] integer swap define-predicate-class ; : CATEGORY: CREATE ";" parse-tokens define-category ; parsing diff --git a/extra/xml-rpc/xml-rpc.factor b/extra/xml-rpc/xml-rpc.factor old mode 100644 new mode 100755 index ffccb5e0f5..1194ff4df1 --- a/extra/xml-rpc/xml-rpc.factor +++ b/extra/xml-rpc/xml-rpc.factor @@ -17,7 +17,7 @@ M: integer item>xml [ "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 ; diff --git a/extra/xml/data/data.factor b/extra/xml/data/data.factor old mode 100644 new mode 100755 index 9d73a46cd9..a7c8bf7b73 --- a/extra/xml/data/data.factor +++ b/extra/xml/data/data.factor @@ -139,5 +139,5 @@ M: xml like : ( name attrs -- tag ) f ; -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 ; From 2614792254e590c280f9e5a9c69ba8146a7fa147 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 27 Mar 2008 11:23:58 +1300 Subject: [PATCH 215/886] Implement packrat algorithm --- extra/peg/peg.factor | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index af26f888f1..44a762cec2 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -3,7 +3,8 @@ USING: kernel sequences strings namespaces math assocs shuffle vectors arrays combinators.lib math.parser match unicode.categories sequences.lib compiler.units parser - words quotations effects memoize accessors combinators.cleave ; + words quotations effects memoize accessors + combinators.cleave locals ; IN: peg TUPLE: parse-result remaining ast ; @@ -14,14 +15,22 @@ SYMBOL: ignore parse-result construct-boa ; SYMBOL: compiled-parsers +SYMBOL: packrat +SYMBOL: failed GENERIC: (compile) ( parser -- quot ) +:: run-packrat-parser ( input quot c -- result ) + input slice? [ input slice-from ] [ 0 ] if + quot c [ drop H{ } clone ] cache + [ + drop input quot call + ] cache* ; inline + : run-parser ( input quot -- result ) - #! Eventually this will be replaced with something that - #! can do packrat parsing by memoizing the results of - #! a parser. For now, it just calls the quotation. - call ; inline + #! If a packrat cache is available, use memoization for + #! packrat parsing, otherwise do a standard peg call. + packrat get [ run-packrat-parser ] [ call ] if* ; inline : compiled-parser ( parser -- word ) #! Look to see if the given parser has been compiled. From be5a09c9e39fc1b0a9421364aa28ede77aa055e1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Mar 2008 18:37:28 -0500 Subject: [PATCH 216/886] Inheritance work in progress --- core/prettyprint/prettyprint.factor | 3 +++ core/tuples/tuples-tests.factor | 14 +++++++------- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 26c6076769..7b8c8f2997 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -257,6 +257,9 @@ M: predicate-class see-class* M: tuple-class see-class* ; diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index e7ad44a264..2d28697b70 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -3,7 +3,7 @@ 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 accessors classes.algebra calendar -prettyprint io.streams.string ; +prettyprint io.streams.string splitting ; IN: tuples.tests TUPLE: rect x y w h ; @@ -247,8 +247,8 @@ C: erg's-reshape-problem ! Inheritance TUPLE: computer cpu ram ; -[ "IN: tuples.tests TUPLE: computer cpu ram ;\n" ] [ - [ \ computer see ] with-string-writer +[ "TUPLE: computer cpu ram ;" ] [ + [ \ computer see ] with-string-writer string-lines second ] unit-test TUPLE: laptop < computer battery ; @@ -264,8 +264,8 @@ C: laptop [ t ] [ "laptop" get computer? ] unit-test [ t ] [ "laptop" get tuple? ] unit-test -[ "IN: tuples.tests TUPLE: laptop < computer battery ;\n" ] [ - [ \ laptop see ] with-string-writer +[ "TUPLE: laptop < computer battery ;" ] [ + [ \ laptop see ] with-string-writer string-lines second ] unit-test TUPLE: server < computer rackmount? ; @@ -288,8 +288,8 @@ C: server [ f ] [ laptop server class< ] unit-test [ f ] [ laptop server classes-intersect? ] unit-test -[ "IN: tuples.tests TUPLE: server < computer rackmount ;\n" ] [ - [ \ server see ] with-string-writer +[ "TUPLE: server < computer rackmount? ;" ] [ + [ \ server see ] with-string-writer string-lines second ] unit-test [ From 7b1bd2f558a7278ad564745dcdc88e07b238af42 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 26 Mar 2008 18:22:25 -0600 Subject: [PATCH 217/886] builder.release: upload binaries to factorcode.org --- extra/builder/release/release.factor | 36 +++++++++++++++++++++++++++- 1 file changed, 35 insertions(+), 1 deletion(-) diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index 0e26abe02f..bb0d16c9da 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -1,6 +1,6 @@ USING: kernel system namespaces sequences splitting combinators - io.files io.launcher + io io.files io.launcher bake combinators.cleave builder.common builder.util ; IN: builder.release @@ -91,6 +91,39 @@ IN: builder.release : remove-factor-app ( -- ) macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: upload-to-factorcode + +: platform ( -- string ) { os cpu- } to-strings "-" join ; + +: 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 ; + +: maybe-upload ( -- ) + upload-to-factorcode get + [ upload ] + when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! : release ( -- ) +! "factor" +! [ +! remove-factor-app +! remove-common-files +! ] +! with-directory +! make-archive +! archive-name releases move-file-into ; + : release ( -- ) "factor" [ @@ -99,6 +132,7 @@ IN: builder.release ] with-directory make-archive + maybe-upload archive-name releases move-file-into ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 9120865157d441f67a8ad8df24624eaf1781373e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 26 Mar 2008 18:47:56 -0500 Subject: [PATCH 218/886] fixing the launcher --- extra/io/unix/launcher/launcher.factor | 3 +- extra/io/windows/files/files.factor | 1 - extra/io/windows/launcher/launcher.factor | 5 ++-- extra/io/windows/nt/files/files.factor | 5 ++-- extra/io/windows/nt/nt-tests.factor | 36 ----------------------- 5 files changed, 8 insertions(+), 42 deletions(-) delete mode 100755 extra/io/windows/nt/nt-tests.factor diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 11c608c68f..0cbb78b881 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.nonblocking io.unix.backend 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 accessors ; +io.unix.launcher.parser accessors io.files ; IN: io.unix.launcher ! Search unix first @@ -67,6 +67,7 @@ USE: unix : spawn-process ( process -- * ) [ + current-directory get cd setup-priority setup-redirection dup pass-environment? [ diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index 35aaf456a3..094014fac6 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -90,4 +90,3 @@ SYMBOLS: +read-only+ +hidden+ +system+ M: windows-nt-io file-info ( path -- info ) get-file-information-stat ; - diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 2d281d0fe8..84f8360840 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -5,7 +5,7 @@ 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 splitting system threads init strings combinators -io.backend accessors concurrency.flags ; +io.backend accessors concurrency.flags io.files ; IN: io.windows.launcher TUPLE: CreateProcess-args @@ -27,7 +27,8 @@ TUPLE: CreateProcess-args "STARTUPINFO" "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo "PROCESS_INFORMATION" >>lpProcessInformation - TRUE >>bInheritHandles ; + TRUE >>bInheritHandles + current-directory get >>lpCurrentDirectory ; : call-CreateProcess ( CreateProcess-args -- ) { diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 540737004b..1c8d88c872 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -3,7 +3,7 @@ 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 -combinators.cleave ; +combinators.cleave namespaces ; IN: io.windows.nt.files M: windows-nt-io cwd @@ -63,11 +63,12 @@ ERROR: not-absolute-path ; ERROR: nonstring-pathname ; ERROR: empty-pathname ; +USE: tools.walker M: windows-nt-io normalize-pathname ( string -- string ) dup string? [ nonstring-pathname ] unless dup empty? [ empty-pathname ] when { { CHAR: / CHAR: \\ } } substitute - cwd swap windows-append-path + current-directory get swap windows-append-path [ "/\\." member? ] right-trim dup peek CHAR: : = [ "\\" append ] when ; diff --git a/extra/io/windows/nt/nt-tests.factor b/extra/io/windows/nt/nt-tests.factor deleted file mode 100755 index 6353bfe86e..0000000000 --- a/extra/io/windows/nt/nt-tests.factor +++ /dev/null @@ -1,36 +0,0 @@ -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-append-path -] unit-test - -[ "\\\\?\\C:\\builds\\" ] [ - "C:\\builds\\factor\\12345\\" - "..\\.." windows-append-path -] unit-test - -[ "\\\\?\\C:\\builds\\" ] [ - "C:\\builds\\factor\\12345\\" - "..\\.." windows-append-path -] unit-test From d823c4a287bf5879b27fc1438fd8abea45c36f87 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 26 Mar 2008 18:48:55 -0500 Subject: [PATCH 219/886] working on random --- extra/random/random.factor | 9 +- .../cryptographic/cryptographic.factor | 29 + extra/windows/advapi32/advapi32.factor | 1554 +++++++++-------- extra/windows/types/types.factor | 1 + 4 files changed, 828 insertions(+), 765 deletions(-) create mode 100644 extra/random/windows/cryptographic/cryptographic.factor diff --git a/extra/random/random.factor b/extra/random/random.factor index 0d8b137fc5..b10e05d415 100755 --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -4,6 +4,8 @@ USING: alien.c-types kernel math namespaces sequences io.backend ; IN: random +SYMBOL: random-generator + HOOK: os-crypto-random-bytes io-backend ( n -- byte-array ) HOOK: os-random-bytes io-backend ( n -- byte-array ) HOOK: os-crypto-random-32 io-backend ( -- r ) @@ -11,16 +13,15 @@ HOOK: os-random-32 io-backend ( -- r ) GENERIC: seed-random ( tuple seed -- ) GENERIC: random-32 ( tuple -- r ) +GENERIC: random-bytes* ( tuple n -- bytes ) -: (random-bytes) ( tuple n -- byte-array ) +M: object random-bytes* ( tuple n -- byte-array ) [ drop random-32 ] with map >c-uint-array ; -SYMBOL: random-generator - : random-bytes ( n -- r ) [ 4 /mod zero? [ 1+ ] unless - random-generator get swap (random-bytes) + random-generator get swap random-bytes* ] keep head ; : random ( seq -- elt ) diff --git a/extra/random/windows/cryptographic/cryptographic.factor b/extra/random/windows/cryptographic/cryptographic.factor new file mode 100644 index 0000000000..158f939af9 --- /dev/null +++ b/extra/random/windows/cryptographic/cryptographic.factor @@ -0,0 +1,29 @@ +USING: accessors alien.c-types byte-arrays continuations +kernel random windows windows.advapi32 ; +IN: random.windows.cryptographic + +TUPLE: windows-crypto-context handle ; + +C: windows-crypto-context + +M: windows-crypto-context dispose ( tuple -- ) + handle>> 0 CryptReleaseContext win32-error=0/f ; + + +TUPLE: windows-cryptographic-rng context ; + +C: windows-cryptographic-rng + +M: windows-cryptographic-rng dispose ( tuple -- ) + context>> dispose ; + +M: windows-cryptographic-rng random-bytes* ( tuple n -- bytes ) + >r context>> r> dup + [ CryptGenRandom win32-error=0/f ] keep ; + +: acquire-aes-context ( -- bytes ) + "HCRYPTPROV" + dup f f PROV_RSA_AES CRYPT_NEWKEYSET + CryptAcquireContextW win32-error=0/f *void* + ; + diff --git a/extra/windows/advapi32/advapi32.factor b/extra/windows/advapi32/advapi32.factor index d3413b5695..0be82551a1 100644 --- a/extra/windows/advapi32/advapi32.factor +++ b/extra/windows/advapi32/advapi32.factor @@ -1,761 +1,793 @@ -USING: alien.syntax kernel math windows.types math.bitfields ; -IN: windows.advapi32 -LIBRARY: advapi32 - -! : 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 ; -! : AddAce ; -! : 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 ; -! : CryptAcquireContextW ; -! : CryptContextAddRef ; -! : CryptCreateHash ; -! : CryptDecrypt ; -! : CryptDeriveKey ; -! : CryptDestroyHash ; -! : CryptDestroyKey ; -! : CryptDuplicateHash ; -! : CryptDuplicateKey ; -! : CryptEncrypt ; -! : CryptEnumProviderTypesA ; -! : CryptEnumProviderTypesW ; -! : CryptEnumProvidersA ; -! : CryptEnumProvidersW ; -! : CryptExportKey ; -! : CryptGenKey ; -! : CryptGenRandom ; -! : CryptGetDefaultProviderA ; -! : CryptGetDefaultProviderW ; -! : CryptGetHashParam ; -! : CryptGetKeyParam ; -! : CryptGetProvParam ; -! : CryptGetUserKey ; -! : CryptHashData ; -! : CryptHashSessionKey ; -! : CryptImportKey ; -! : CryptReleaseContext ; -! : 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 ; -! : InitializeAcl ; -! : 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 ; - -! typedef enum _TOKEN_INFORMATION_CLASS { -: TokenUser 1 ; -: TokenGroups 2 ; -: TokenPrivileges 3 ; -: TokenOwner 4 ; -: TokenPrimaryGroup 5 ; -: TokenDefaultDacl 6 ; -: TokenSource 7 ; -: TokenType 8 ; -: TokenImpersonationLevel 9 ; -: TokenStatistics 10 ; -: TokenRestrictedSids 11 ; -: TokenSessionId 12 ; -: TokenGroupsAndPrivileges 13 ; -: TokenSessionReference 14 ; -: TokenSandBoxInert 15 ; -! } 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 - -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.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 + +: 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 + + +! : 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 ; +! : AddAce ; +! : 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 ; +! : InitializeAcl ; +! : 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 ; + +! typedef enum _TOKEN_INFORMATION_CLASS { +: TokenUser 1 ; +: TokenGroups 2 ; +: TokenPrivileges 3 ; +: TokenOwner 4 ; +: TokenPrimaryGroup 5 ; +: TokenDefaultDacl 6 ; +: TokenSource 7 ; +: TokenType 8 ; +: TokenImpersonationLevel 9 ; +: TokenStatistics 10 ; +: TokenRestrictedSids 11 ; +: TokenSessionId 12 ; +: TokenGroupsAndPrivileges 13 ; +: TokenSessionReference 14 ; +: TokenSandBoxInert 15 ; +! } 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 + +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 ; + + diff --git a/extra/windows/types/types.factor b/extra/windows/types/types.factor index 7be8d98e61..61b409e8e1 100644 --- a/extra/windows/types/types.factor +++ b/extra/windows/types/types.factor @@ -113,6 +113,7 @@ TYPEDEF: HANDLE HSZ 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 From c0f4e3742746573a5ae93df138cd80bf078ad4b6 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 27 Mar 2008 12:58:53 +1300 Subject: [PATCH 220/886] Fix usage of cache in pegs --- extra/peg/peg.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 44a762cec2..dd0b11fce3 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -25,7 +25,7 @@ GENERIC: (compile) ( parser -- quot ) quot c [ drop H{ } clone ] cache [ drop input quot call - ] cache* ; inline + ] cache ; inline : run-parser ( input quot -- result ) #! If a packrat cache is available, use memoization for From 4684c9cacc1c740d908510e327946b2d7bcff8a0 Mon Sep 17 00:00:00 2001 From: erg Date: Wed, 26 Mar 2008 19:40:40 -0500 Subject: [PATCH 221/886] work on normalize-pathname add two failing unit tests --- core/io/backend/backend.factor | 2 -- core/io/files/files-tests.factor | 17 +++++++++++++++-- core/io/files/files.factor | 3 +++ 3 files changed, 18 insertions(+), 4 deletions(-) diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 1595ecd576..8cfcbb71de 100755 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -21,8 +21,6 @@ M: object normalize-directory ; HOOK: normalize-pathname io-backend ( str -- newstr ) -M: object normalize-pathname ; - : set-io-backend ( io-backend -- ) io-backend set-global init-io init-stdio ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 36b32ea34c..51bf79e29c 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,6 +1,7 @@ IN: io.files.tests -USING: tools.test io.files io threads kernel continuations io.encodings.ascii -io.files.unique sequences strings accessors ; +USING: tools.test io.files 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 @@ -130,6 +131,18 @@ io.files.unique sequences strings accessors ; [ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test +[ t ] [ + temp-directory [ "hi" "test41" utf8 set-file-contents ] with-directory + temp-directory "test41" append-path utf8 file-contents "hi41" = +] unit-test + +[ t ] [ + temp-directory [ + "test43" utf8 [ "hi43" write ] with-stream + ] with-directory + temp-directory "test43" append-path utf8 file-contents "hi43" = +] unit-test + [ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test [ ] [ "append-test" temp-file ascii dispose ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 6500bdb387..64d8e25ee2 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -272,6 +272,9 @@ DEFER: copy-tree-into : temp-file ( name -- path ) temp-directory prepend-path ; +M: object normalize-pathname ( path -- path' ) + current-directory get prepend-path ; + ! Pathname presentations TUPLE: pathname string ; From e2f3888389e846843ff8bab2e1cec0f6cd589303 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Mar 2008 20:42:24 -0500 Subject: [PATCH 222/886] UI listener fix --- extra/ui/gadgets/scrollers/scrollers.factor | 5 +++-- extra/ui/tools/listener/listener.factor | 15 +++++++++++++-- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/extra/ui/gadgets/scrollers/scrollers.factor index 98951b74e3..7966f4e206 100755 --- a/extra/ui/gadgets/scrollers/scrollers.factor +++ b/extra/ui/gadgets/scrollers/scrollers.factor @@ -3,13 +3,14 @@ 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 ; +namespaces sequences models combinators math.vectors +tuples ; 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 ; diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 75401b3861..7db0d63f45 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -6,7 +6,8 @@ kernel models namespaces parser quotations sequences ui.commands 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 ; IN: ui.tools.listener TUPLE: listener-gadget input output stack ; @@ -23,9 +24,19 @@ TUPLE: listener-gadget input output stack ; : ( listener -- gadget ) listener-gadget-output ; +TUPLE: input-scroller ; + +: ( interactor -- scroller ) + + input-scroller construct-empty + [ set-gadget-delegate ] keep ; + +M: input-scroller pref-dim* + drop { 0 100 } ; + : listener-input, ( -- ) g g-> set-listener-gadget-input - "Input" f track, ; + "Input" f track, ; : welcome. ( -- ) "If this is your first time with Factor, please read the " print From e6da3bc43a66f23b75586c4b320208fed4c59579 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 27 Mar 2008 14:55:14 +1300 Subject: [PATCH 223/886] Use cache in compiled-parser in peg --- extra/peg/peg.factor | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index dd0b11fce3..fe58962f48 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -16,7 +16,6 @@ SYMBOL: ignore SYMBOL: compiled-parsers SYMBOL: packrat -SYMBOL: failed GENERIC: (compile) ( parser -- quot ) @@ -36,12 +35,9 @@ GENERIC: (compile) ( parser -- quot ) #! 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. - dup compiled-parsers get at [ - nip - ] [ - dup (compile) [ run-parser ] curry define-temp - [ swap compiled-parsers get set-at ] keep - ] if* ; + compiled-parsers get [ + (compile) [ run-parser ] curry define-temp + ] cache ; : compile ( parser -- word ) H{ } clone compiled-parsers [ From 7c0535884eeb8d770ad0d09a18221d1438c7b2e4 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 27 Mar 2008 15:21:38 +1300 Subject: [PATCH 224/886] Fix up peg memoization of compiled parsers --- extra/peg/peg.factor | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index fe58962f48..c994c5aa29 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -14,9 +14,14 @@ SYMBOL: ignore : ( remaining ast -- parse-result ) parse-result construct-boa ; -SYMBOL: compiled-parsers SYMBOL: packrat +: compiled-parsers ( -- cache ) + \ compiled-parsers get-global [ H{ } clone dup \ compiled-parsers set-global ] unless* ; + +: reset-compiled-parsers ( -- ) + H{ } clone \ compiled-parsers set-global ; + GENERIC: (compile) ( parser -- quot ) :: run-packrat-parser ( input quot c -- result ) @@ -35,14 +40,12 @@ GENERIC: (compile) ( parser -- quot ) #! 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. - compiled-parsers get [ + compiled-parsers [ (compile) [ run-parser ] curry define-temp ] cache ; : compile ( parser -- word ) - H{ } clone compiled-parsers [ - [ compiled-parser ] with-compilation-unit - ] with-variable ; + [ compiled-parser ] with-compilation-unit ; : parse ( state parser -- result ) compile execute ; From 708726d20838833899ce7ddfb9aae19efa10bc1a Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 27 Mar 2008 15:50:27 +1300 Subject: [PATCH 225/886] Add with-packrat word and more memoization --- extra/peg/parsers/parsers.factor | 17 ++++----- extra/peg/peg-docs.factor | 31 ++++++++++++++++- extra/peg/peg.factor | 60 ++++++++++++++++++++------------ 3 files changed, 77 insertions(+), 31 deletions(-) diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 13509e81f7..fa6801dc1c 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -3,10 +3,11 @@ USING: kernel sequences strings namespaces math assocs shuffle vectors arrays combinators.lib math.parser match unicode.categories sequences.deep peg peg.private - peg.search math.ranges words ; + peg.search math.ranges words memoize ; IN: peg.parsers TUPLE: just-parser p1 ; +M: just-parser equal? 2drop f ; : just-pattern [ @@ -19,7 +20,7 @@ TUPLE: just-parser p1 ; M: just-parser (compile) ( parser -- quot ) just-parser-p1 compiled-parser just-pattern curry ; -: just ( parser -- parser ) +MEMO: just ( parser -- parser ) just-parser construct-boa ; : 1token ( ch -- parser ) 1string token ; @@ -47,10 +48,10 @@ PRIVATE> PRIVATE> -: exactly-n ( parser n -- parser' ) +MEMO: exactly-n ( parser n -- parser' ) swap seq ; -: at-most-n ( parser n -- parser' ) +MEMO: at-most-n ( parser n -- parser' ) dup zero? [ 2drop epsilon ] [ @@ -58,15 +59,15 @@ PRIVATE> -rot 1- at-most-n 2choice ] if ; -: at-least-n ( parser n -- parser' ) +MEMO: at-least-n ( parser n -- parser' ) dupd exactly-n swap repeat0 2seq [ flatten-vectors ] action ; -: from-m-to-n ( parser m n -- parser' ) +MEMO: from-m-to-n ( parser m n -- parser' ) >r [ exactly-n ] 2keep r> swap - at-most-n 2seq [ flatten-vectors ] action ; -: pack ( begin body end -- parser ) +MEMO: pack ( begin body end -- parser ) >r >r hide r> r> hide 3seq [ first ] action ; : surrounded-by ( parser begin end -- parser' ) @@ -83,7 +84,7 @@ PRIVATE> [ 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 diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index 9ad375ea04..30e7f0e72f 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -11,7 +11,36 @@ HELP: parse } { $description "Given the input string, parse it using the given parser. The result is a object if " - "the parse was successful, otherwise it is f." } ; + "the parse was successful, otherwise it is f." } +{ $see-also compile with-packrat } ; + +HELP: with-packrat +{ $values + { "quot" "a quotation with stack effect ( input -- result )" } + { "result" "the result of the quotation" } +} +{ $description + "Calls the quotation with a packrat cache in scope. Usually the quotation will " + "call " { $link parse } " or call a word produced by " { $link compile } "." + "The cache is used to avoid the possible exponential time performace that pegs " + "can have, instead giving linear time at the cost of increased memory usage." } +{ $see-also compile parse } ; + +HELP: compile +{ $values + { "parser" "a parser" } + { "word" "a word" } +} +{ $description + "Compile the parser to a word. The word will have stack effect ( input -- result )." + "The mapping from parser to compiled word is kept in a cache. If you later change " + "the definition of a parser you'll need to clear this cache with " + { $link reset-compiled-parsers } " before using " { $link compile } " on that parser again." } +{ $see-also compile with-packrat reset-compiled-parsers } ; + +HELP: reset-compiled-parsers +{ $description + "Reset the cache mapping parsers to compiled words." } ; HELP: token { $values diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index c994c5aa29..10c9ce907d 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -50,10 +50,14 @@ GENERIC: (compile) ( parser -- quot ) : parse ( state parser -- result ) compile execute ; +: with-packrat ( quot -- result ) + #! Run the quotation with a packrat cache active. + [ H{ } clone packrat ] dip with-variable ; + > [ parse-token ] curry ; TUPLE: satisfy-parser quot ; +M: satisfy-parser equal? 2drop f ; MATCH-VARS: ?quot ; @@ -89,6 +94,7 @@ M: satisfy-parser (compile) ( parser -- quot ) quot>> \ ?quot satisfy-pattern match-replace ; TUPLE: range-parser min max ; +M: range-parser equal? 2drop f ; MATCH-VARS: ?min ?max ; @@ -110,6 +116,7 @@ M: range-parser (compile) ( parser -- quot ) T{ range-parser _ ?min ?max } range-pattern match-replace ; TUPLE: seq-parser parsers ; +M: seq-parser equal? 2drop f ; : seq-pattern ( -- quot ) [ @@ -136,6 +143,7 @@ M: seq-parser (compile) ( parser -- quot ) ] [ ] make ; TUPLE: choice-parser parsers ; +M: choice-parser equal? 2drop f ; : choice-pattern ( -- quot ) [ @@ -154,6 +162,7 @@ M: choice-parser (compile) ( parser -- quot ) ] [ ] make ; TUPLE: repeat0-parser p1 ; +M: repeat0-parser equal? 2drop f ; : (repeat0) ( quot result -- result ) 2dup remaining>> swap call [ @@ -176,6 +185,7 @@ M: repeat0-parser (compile) ( parser -- quot ) ] [ ] make ; TUPLE: repeat1-parser p1 ; +M: repeat1-parser equal? 2drop f ; : repeat1-pattern ( -- quot ) [ @@ -195,6 +205,7 @@ M: repeat1-parser (compile) ( parser -- quot ) ] [ ] make ; TUPLE: optional-parser p1 ; +M: optional-parser equal? 2drop f ; : optional-pattern ( -- quot ) [ @@ -205,6 +216,7 @@ M: optional-parser (compile) ( parser -- quot ) p1>> compiled-parser \ ?quot optional-pattern match-replace ; TUPLE: ensure-parser p1 ; +M: ensure-parser equal? 2drop f ; : ensure-pattern ( -- quot ) [ @@ -219,6 +231,7 @@ M: ensure-parser (compile) ( parser -- quot ) p1>> compiled-parser \ ?quot ensure-pattern match-replace ; TUPLE: ensure-not-parser p1 ; +M: ensure-not-parser equal? 2drop f ; : ensure-not-pattern ( -- quot ) [ @@ -233,6 +246,7 @@ M: ensure-not-parser (compile) ( parser -- quot ) p1>> compiled-parser \ ?quot ensure-not-pattern match-replace ; TUPLE: action-parser p1 quot ; +M: action-parser equal? 2drop f ; MATCH-VARS: ?action ; @@ -256,6 +270,7 @@ M: action-parser (compile) ( parser -- quot ) ] unless ; TUPLE: sp-parser p1 ; +M: sp-parser equal? 2drop f ; M: sp-parser (compile) ( parser -- quot ) [ @@ -263,6 +278,7 @@ M: sp-parser (compile) ( parser -- quot ) ] [ ] make ; TUPLE: delay-parser quot ; +M: delay-parser equal? 2drop f ; M: delay-parser (compile) ( parser -- quot ) #! For efficiency we memoize the quotation. @@ -276,70 +292,70 @@ M: delay-parser (compile) ( parser -- quot ) PRIVATE> -: token ( string -- parser ) +MEMO: token ( string -- parser ) token-parser construct-boa ; -: satisfy ( quot -- parser ) +MEMO: satisfy ( quot -- parser ) satisfy-parser construct-boa ; -: range ( min max -- parser ) +MEMO: range ( min max -- parser ) range-parser construct-boa ; -: seq ( seq -- parser ) +MEMO: seq ( seq -- parser ) seq-parser construct-boa ; -: 2seq ( parser1 parser2 -- parser ) +MEMO: 2seq ( parser1 parser2 -- parser ) 2array seq ; -: 3seq ( parser1 parser2 parser3 -- parser ) +MEMO: 3seq ( parser1 parser2 parser3 -- parser ) 3array seq ; -: 4seq ( parser1 parser2 parser3 parser4 -- parser ) +MEMO: 4seq ( parser1 parser2 parser3 parser4 -- parser ) 4array seq ; -: seq* ( quot -- paser ) +MEMO: seq* ( quot -- paser ) { } make seq ; inline -: choice ( seq -- parser ) +MEMO: choice ( seq -- parser ) choice-parser construct-boa ; -: 2choice ( parser1 parser2 -- parser ) +MEMO: 2choice ( parser1 parser2 -- parser ) 2array choice ; -: 3choice ( parser1 parser2 parser3 -- parser ) +MEMO: 3choice ( parser1 parser2 parser3 -- parser ) 3array choice ; -: 4choice ( parser1 parser2 parser3 parser4 -- parser ) +MEMO: 4choice ( parser1 parser2 parser3 parser4 -- parser ) 4array choice ; -: choice* ( quot -- paser ) +MEMO: choice* ( quot -- paser ) { } make choice ; inline -: repeat0 ( parser -- parser ) +MEMO: repeat0 ( parser -- parser ) repeat0-parser construct-boa ; -: repeat1 ( parser -- parser ) +MEMO: repeat1 ( parser -- parser ) repeat1-parser construct-boa ; -: optional ( parser -- parser ) +MEMO: optional ( parser -- parser ) optional-parser construct-boa ; -: ensure ( parser -- parser ) +MEMO: ensure ( parser -- parser ) ensure-parser construct-boa ; -: ensure-not ( parser -- parser ) +MEMO: ensure-not ( parser -- parser ) ensure-not-parser construct-boa ; -: action ( parser quot -- parser ) +MEMO: action ( parser quot -- parser ) action-parser construct-boa ; -: sp ( parser -- parser ) +MEMO: sp ( parser -- parser ) sp-parser construct-boa ; : hide ( parser -- parser ) [ drop ignore ] action ; -: delay ( quot -- parser ) +MEMO: delay ( quot -- parser ) delay-parser construct-boa ; : PEG: From bc5f82255fbdeeb11f3b3cfef555856ec2dcb8cf Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 27 Mar 2008 17:24:05 +1300 Subject: [PATCH 226/886] peg refactorings --- extra/peg/peg.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 10c9ce907d..0ae2aba2ee 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -24,8 +24,13 @@ SYMBOL: packrat GENERIC: (compile) ( parser -- quot ) +: 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 ; + :: run-packrat-parser ( input quot c -- result ) - input slice? [ input slice-from ] [ 0 ] if + input input-from quot c [ drop H{ } clone ] cache [ drop input quot call From 4c50daed2213b9442954aec3a38abb51586fd05c Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 27 Mar 2008 17:45:59 +1300 Subject: [PATCH 227/886] Testcase for packrat behaviour --- extra/peg/peg-tests.factor | 20 ++++++++++++++++++++ extra/peg/peg.factor | 18 ++++++++++++++---- 2 files changed, 34 insertions(+), 4 deletions(-) diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index 89cc243863..bd4699f097 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -158,3 +158,23 @@ IN: peg.tests "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 + +{ 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 + ] with-packrat +] unit-test \ No newline at end of file diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 0ae2aba2ee..bbd55ec6fa 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -29,12 +29,22 @@ GENERIC: (compile) ( parser -- quot ) #! input slice is based on. dup slice? [ slice-from ] [ drop 0 ] if ; +: input-cache ( quot cache -- cache ) + #! From the packrat cache, obtain the cache for the parser quotation + #! that maps the input string position to the parser result. + [ drop H{ } clone ] cache ; + +: cached-result ( n input-cache input quot -- result ) + #! Get the cached result for input position n + #! from the input cache. If the item is not in the cache, + #! call 'quot' with 'input' on the stack to get the result + #! and store that in the cache and return it. + [ nip ] swap compose curry cache ; inline + :: run-packrat-parser ( input quot c -- result ) input input-from - quot c [ drop H{ } clone ] cache - [ - drop input quot call - ] cache ; inline + quot c input-cache + input quot cached-result ; inline : run-parser ( input quot -- result ) #! If a packrat cache is available, use memoization for From 4e29081e93aadb902ebbcc27d9c2049d73434adb Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 27 Mar 2008 18:07:30 +1300 Subject: [PATCH 228/886] Make left recursion in pegs a failed parse Eventually left recursion will work fine, but this is prevents an infinite loop for now. --- extra/peg/peg-tests.factor | 4 +++- extra/peg/peg.factor | 4 ++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index bd4699f097..bd8abb63e6 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -175,6 +175,8 @@ IN: peg.tests [ "1" token , "+" token , "1" token , ] seq* , ] choice* "1-1" over parse parse-result-ast swap - "1+1" swap parse parse-result-ast ] with-packrat + [ + "1+1" swap parse parse-result-ast + ] with-packrat ] unit-test \ No newline at end of file diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index bbd55ec6fa..1361f9fdbd 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -34,12 +34,12 @@ GENERIC: (compile) ( parser -- quot ) #! that maps the input string position to the parser result. [ drop H{ } clone ] cache ; -: cached-result ( n input-cache input quot -- result ) +:: cached-result ( n input-cache input quot -- result ) #! Get the cached result for input position n #! from the input cache. If the item is not in the cache, #! call 'quot' with 'input' on the stack to get the result #! and store that in the cache and return it. - [ nip ] swap compose curry cache ; inline + n input-cache [ drop input quot call ] cache ; inline :: run-packrat-parser ( input quot c -- result ) input input-from From cb3fdc5c7d6e55a6914ba40298c9badc1c70fe96 Mon Sep 17 00:00:00 2001 From: erg Date: Fri, 28 Mar 2008 21:40:02 -0500 Subject: [PATCH 229/886] fix the Makefile and make targets --- Makefile | 7 +-- {misc => build-support}/factor.sh | 81 ++++++++++++++++--------------- build-support/target | 38 --------------- build-support/wordsize.c | 8 --- 4 files changed, 44 insertions(+), 90 deletions(-) rename {misc => build-support}/factor.sh (87%) delete mode 100755 build-support/target delete mode 100644 build-support/wordsize.c diff --git a/Makefile b/Makefile index ecb333a0b2..7bced81e47 100755 --- a/Makefile +++ b/Makefile @@ -45,8 +45,8 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ EXE_OBJS = $(PLAF_EXE_OBJS) -default: build-support/wordsize - $(MAKE) `./build-support/target` +default: + $(MAKE) `./misc/factor.sh make-target` help: @echo "Run '$(MAKE)' with one of the following parameters:" @@ -162,9 +162,6 @@ factor: $(DLL_OBJS) $(EXE_OBJS) $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) -build-support/wordsize: build-support/wordsize.c - gcc build-support/wordsize.c -o build-support/wordsize - clean: rm -f vm/*.o rm -f factor*.dll libfactor*.* diff --git a/misc/factor.sh b/build-support/factor.sh similarity index 87% rename from misc/factor.sh rename to build-support/factor.sh index 09531350f3..d2a94b8a17 100755 --- a/misc/factor.sh +++ b/build-support/factor.sh @@ -7,6 +7,7 @@ set +e shopt -s nocaseglob #shopt -s nocasematch +ECHO=echo OS= ARCH= WORD= @@ -25,23 +26,23 @@ ensure_program_installed() { installed=0; for i in $* ; do - echo -n "Checking for $i..." + $ECHO -n "Checking for $i..." test_program_installed $i if [[ $? -eq 0 ]]; then echo -n "not " else installed=$(( $installed + 1 )) fi - echo "found!" + $ECHO "found!" done if [[ $installed -eq 0 ]] ; then - echo -n "Install " + $ECHO -n "Install " if [[ $# -eq 1 ]] ; then - echo -n $1 + $ECHO -n $1 else - echo -n "any of [ $* ]" + $ECHO -n "any of [ $* ]" fi - echo " and try again." + $ECHO " and try again." exit 1 fi } @@ -49,22 +50,22 @@ ensure_program_installed() { check_ret() { RET=$? if [[ $RET -ne 0 ]] ; then - echo $1 failed + $ECHO $1 failed exit 2 fi } check_gcc_version() { - echo -n "Checking 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." + $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." + $ECHO "ok." } set_downloader() { @@ -125,20 +126,20 @@ check_installed_programs() { 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 + $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" + $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." + $ECHO "found." } check_X11_libraries() { @@ -156,14 +157,14 @@ check_libraries() { check_factor_exists() { if [[ -d "factor" ]] ; then - echo "A directory called 'factor' already exists." - echo "Rename or delete it and try again." + $ECHO "A directory called 'factor' already exists." + $ECHO "Rename or delete it and try again." exit 4 fi } find_os() { - echo "Finding OS..." + $ECHO "Finding OS..." uname_s=`uname -s` check_ret uname case $uname_s in @@ -182,7 +183,7 @@ find_os() { } find_architecture() { - echo "Finding ARCH..." + $ECHO "Finding ARCH..." uname_m=`uname -m` check_ret uname case $uname_m in @@ -201,7 +202,7 @@ write_test_program() { } find_word_size() { - echo "Finding WORD..." + $ECHO "Finding WORD..." C_WORD=factor-word-size write_test_program gcc -o $C_WORD $C_WORD.c @@ -219,26 +220,26 @@ set_factor_binary() { } 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 + $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" + $ECHO "OS: $OS" + $ECHO "ARCH: $ARCH" + $ECHO "WORD: $WORD" + $ECHO "OS, ARCH, or WORD is empty. Please report this" exit 5 fi @@ -452,5 +453,7 @@ case "$1" in bootstrap) get_config_info; bootstrap ;; dlls) get_config_info; maybe_download_dlls;; net-bootstrap) get_config_info; update_boot_images; bootstrap ;; + #make-target) ECHO=`echo #`; find_build_info; echo $MAKE_TARGET ;; + make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;; *) usage ;; esac diff --git a/build-support/target b/build-support/target deleted file mode 100755 index ffb677b681..0000000000 --- a/build-support/target +++ /dev/null @@ -1,38 +0,0 @@ -#!/usr/bin/env bash - -uname_s=`uname -s` -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 - -uname_m=`uname -m` -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 - -WORD=`./build-support/wordsize` - -MAKE_TARGET=$OS-$ARCH-$WORD -if [[ $OS == macosx && $ARCH == ppc ]] ; then - MAKE_TARGET=$OS-$ARCH -fi -if [[ $OS == linux && $ARCH == ppc ]] ; then - MAKE_TARGET=$OS-$ARCH -fi - -echo $MAKE_TARGET diff --git a/build-support/wordsize.c b/build-support/wordsize.c deleted file mode 100644 index a0e7d0b9c0..0000000000 --- a/build-support/wordsize.c +++ /dev/null @@ -1,8 +0,0 @@ - -#include - -int main () -{ - printf("%d", 8*sizeof(void*)); - return 0; -} From 4feebaa8e8f2f5d4de3a1d28c1ff0679e542b412 Mon Sep 17 00:00:00 2001 From: erg Date: Fri, 28 Mar 2008 21:42:19 -0500 Subject: [PATCH 230/886] remove dead code --- build-support/factor.sh | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index d2a94b8a17..476e885257 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -438,7 +438,7 @@ install_build_system_port() { } usage() { - echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap" + echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap|make-target" echo "If you are behind a firewall, invoke as:" echo "env GIT_PROTOCOL=http $0 " } @@ -453,7 +453,6 @@ case "$1" in bootstrap) get_config_info; bootstrap ;; dlls) get_config_info; maybe_download_dlls;; net-bootstrap) get_config_info; update_boot_images; bootstrap ;; - #make-target) ECHO=`echo #`; find_build_info; echo $MAKE_TARGET ;; make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;; *) usage ;; esac From 37cffc50fa5037b5ff6da39983ecc60fc7e89bc8 Mon Sep 17 00:00:00 2001 From: erg Date: Fri, 28 Mar 2008 22:10:01 -0500 Subject: [PATCH 231/886] fix random add with-secure-random --- extra/random/backend/backend.factor | 24 ++++++++++++ extra/random/dummy/dummy.factor | 2 +- .../mersenne-twister-tests.factor | 2 +- .../mersenne-twister/mersenne-twister.factor | 3 +- extra/random/random-tests.factor | 5 +++ extra/random/random.factor | 38 +++++++++---------- extra/random/unix/unix.factor | 23 ++++++----- .../cryptographic/cryptographic.factor | 28 -------------- extra/random/windows/windows.factor | 30 ++++++++++++++- 9 files changed, 91 insertions(+), 64 deletions(-) create mode 100755 extra/random/backend/backend.factor create mode 100644 extra/random/random-tests.factor delete mode 100644 extra/random/windows/cryptographic/cryptographic.factor diff --git a/extra/random/backend/backend.factor b/extra/random/backend/backend.factor new file mode 100755 index 0000000000..c5243c22bd --- /dev/null +++ b/extra/random/backend/backend.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types kernel math namespaces sequences +io.backend io.binary combinators system vocabs.loader ; +IN: random.backend + +SYMBOL: insecure-random-generator +SYMBOL: secure-random-generator +SYMBOL: random-generator + +GENERIC: seed-random ( tuple seed -- ) +GENERIC: random-32* ( tuple -- r ) +GENERIC: random-bytes* ( n tuple -- bytes ) + +M: object random-bytes* ( n tuple -- byte-array ) + swap [ drop random-32* ] with map >c-uint-array ; + +M: object random-32* ( tuple -- n ) 4 random-bytes* le> ; + +ERROR: no-random-number-generator ; + +M: f random-bytes* ( n obj -- * ) no-random-number-generator ; + +M: f random-32* ( obj -- * ) no-random-number-generator ; diff --git a/extra/random/dummy/dummy.factor b/extra/random/dummy/dummy.factor index 9120381955..a17ef54982 100755 --- a/extra/random/dummy/dummy.factor +++ b/extra/random/dummy/dummy.factor @@ -1,4 +1,4 @@ -USING: kernel random math accessors ; +USING: kernel random math accessors random.backend ; IN: random.dummy TUPLE: random-dummy i ; diff --git a/extra/random/mersenne-twister/mersenne-twister-tests.factor b/extra/random/mersenne-twister/mersenne-twister-tests.factor index 703a0c16e4..9eb546063e 100755 --- a/extra/random/mersenne-twister/mersenne-twister-tests.factor +++ b/extra/random/mersenne-twister/mersenne-twister-tests.factor @@ -1,5 +1,5 @@ USING: kernel math random namespaces random.mersenne-twister -sequences tools.test ; +sequences tools.test random.backend ; IN: random.mersenne-twister.tests : check-random ( max -- ? ) diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index 53ec91b118..f43ef9f852 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -4,7 +4,8 @@ ! 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 combinators.cleave random new-effects ; +accessors math.ranges combinators.cleave random new-effects +random.backend ; IN: random.mersenne-twister c-uint-array ; - -M: object random-32* ( tuple -- n ) - 4 random-bytes* le> ; - : random-bytes ( n -- r ) [ - 4 /mod zero? [ 1+ ] unless - random-generator get swap random-bytes* + dup 4 rem zero? [ 1+ ] unless + random-generator get random-bytes* ] keep head ; : random ( seq -- elt ) @@ -41,3 +26,16 @@ M: object random-32* ( tuple -- n ) : with-random ( tuple quot -- ) random-generator swap with-variable ; inline + +: with-secure-random ( quot -- ) + >r secure-random-generator get r> with-random ; inline + +{ + { [ windows? ] [ "random.windows" require ] } + { [ unix? ] [ "random.unix" require ] } +} cond + +[ + [ 32 random-bits ] with-secure-random + random-generator set-global +] "random" add-init-hook diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor index f41a3ae0e8..78765bc575 100644 --- a/extra/random/unix/unix.factor +++ b/extra/random/unix/unix.factor @@ -1,22 +1,21 @@ USING: alien.c-types io io.files io.nonblocking kernel -namespaces random io.encodings.binary singleton ; +namespaces random.backend io.encodings.binary singleton init +accessors ; IN: random.unix -SINGLETON: unix-random +TUPLE: unix-random path ; + +C: unix-random : file-read-unbuffered ( n path -- bytes ) over default-buffer-size [ binary [ read ] with-stream ] with-variable ; -M: unix-random os-crypto-random-bytes ( n -- byte-array ) - "/dev/random" file-read-unbuffered ; +M: unix-random random-bytes* ( n tuple -- byte-array ) + path>> file-read-unbuffered ; -M: unix-random os-random-bytes ( n -- byte-array ) - "/dev/urandom" file-read-unbuffered ; - -M: unix-random os-crypto-random-32 ( -- r ) - 4 os-crypto-random-bytes *uint ; - -M: unix-random os-random-32 ( -- r ) - 4 os-random-bytes *uint ; +[ + "/dev/random" secure-random-generator set-global + "/dev/urandom" insecure-random-generator set-global +] "random.unix" add-init-hook diff --git a/extra/random/windows/cryptographic/cryptographic.factor b/extra/random/windows/cryptographic/cryptographic.factor deleted file mode 100644 index 3f64209200..0000000000 --- a/extra/random/windows/cryptographic/cryptographic.factor +++ /dev/null @@ -1,28 +0,0 @@ -USING: accessors alien.c-types byte-arrays continuations -kernel random windows windows.advapi32 ; -IN: random.windows.cryptographic - -TUPLE: windows-crypto-context handle ; - -C: windows-crypto-context - -M: windows-crypto-context dispose ( tuple -- ) - handle>> 0 CryptReleaseContext win32-error=0/f ; - - -TUPLE: windows-cryptographic-rng context ; - -C: windows-cryptographic-rng - -M: windows-cryptographic-rng dispose ( tuple -- ) - context>> dispose ; - -M: windows-cryptographic-rng random-bytes* ( tuple n -- bytes ) - >r context>> r> dup - [ CryptGenRandom win32-error=0/f ] keep ; - -: acquire-aes-context ( -- bytes ) - "HCRYPTPROV" - dup f f PROV_RSA_AES CRYPT_NEWKEYSET - CryptAcquireContextW win32-error=0/f *void* - ; diff --git a/extra/random/windows/windows.factor b/extra/random/windows/windows.factor index 8b3c1012c8..2b5caabfed 100644 --- a/extra/random/windows/windows.factor +++ b/extra/random/windows/windows.factor @@ -1,3 +1,31 @@ +USING: accessors alien.c-types byte-arrays continuations +kernel random windows windows.advapi32 init namespaces random ; IN: random.windows -! M: windows-io +TUPLE: windows-crypto-context handle ; + +C: windows-crypto-context + +M: windows-crypto-context dispose ( tuple -- ) + handle>> 0 CryptReleaseContext win32-error=0/f ; + +TUPLE: windows-cryptographic-rng context ; + +C: windows-cryptographic-rng + +M: windows-cryptographic-rng dispose ( tuple -- ) + context>> dispose ; + +M: windows-cryptographic-rng random-bytes* ( tuple n -- bytes ) + >r context>> r> dup + [ CryptGenRandom win32-error=0/f ] keep ; + +: windows-aes-context ( -- context ) + "HCRYPTPROV" + dup f f PROV_RSA_AES CRYPT_NEWKEYSET + CryptAcquireContextW win32-error=0/f *void* + ; + +[ + windows-aes-context secure-random-generator set-global +] "random.windows" add-init-hook From 71856836631c2b081424c095d746da808cb8aa2c Mon Sep 17 00:00:00 2001 From: erg Date: Fri, 28 Mar 2008 22:12:11 -0500 Subject: [PATCH 232/886] test with-secure-random --- extra/random/random-tests.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/random/random-tests.factor b/extra/random/random-tests.factor index 0ceac5f5a7..d85df3e0be 100644 --- a/extra/random/random-tests.factor +++ b/extra/random/random-tests.factor @@ -3,3 +3,6 @@ IN: random.tests [ 4 ] [ 4 random-bytes length ] unit-test [ 7 ] [ 7 random-bytes length ] unit-test + +[ 4 ] [ [ 4 random-bytes length ] with-secure-random ] unit-test +[ 7 ] [ [ 7 random-bytes length ] with-secure-random ] unit-test From 89cacd416b3e6edb3c79ff6135cf3a8673b84340 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Mar 2008 05:51:48 -0500 Subject: [PATCH 233/886] fix load errors on windows --- extra/random/mersenne-twister/mersenne-twister.factor | 2 +- extra/random/windows/windows.factor | 9 +++++---- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index f43ef9f852..4eb93f2941 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -4,7 +4,7 @@ ! 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 combinators.cleave random new-effects +accessors math.ranges combinators.cleave new-effects random.backend ; IN: random.mersenne-twister diff --git a/extra/random/windows/windows.factor b/extra/random/windows/windows.factor index 2b5caabfed..ef0d10059e 100644 --- a/extra/random/windows/windows.factor +++ b/extra/random/windows/windows.factor @@ -1,5 +1,6 @@ USING: accessors alien.c-types byte-arrays continuations -kernel random windows windows.advapi32 init namespaces random ; +kernel windows windows.advapi32 init namespaces +random.backend ; IN: random.windows TUPLE: windows-crypto-context handle ; @@ -26,6 +27,6 @@ M: windows-cryptographic-rng random-bytes* ( tuple n -- bytes ) CryptAcquireContextW win32-error=0/f *void* ; -[ - windows-aes-context secure-random-generator set-global -] "random.windows" add-init-hook +! [ + ! windows-aes-context secure-random-generator set-global +! ] "random.windows" add-init-hook From f6b7f8197e5e1bf033157bdcd389aa216383a29e Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 27 Mar 2008 23:54:34 +1300 Subject: [PATCH 234/886] Add tests for left recusion in pegs --- extra/peg/ebnf/ebnf-tests.factor | 30 +++++++++++++++++++++++++++++- extra/peg/ebnf/ebnf.factor | 4 ++-- extra/peg/peg-tests.factor | 18 +++++++++++++++++- extra/peg/peg.factor | 6 +++++- 4 files changed, 53 insertions(+), 5 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index c9b9f5d977..dea549eb37 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -142,4 +142,32 @@ IN: peg.ebnf.tests { f } [ "Z" [EBNF foo=[^A-Z] EBNF] call -] unit-test \ No newline at end of file +] unit-test + +[ + #! Test direct left recursion. Currently left recursion should cause a + #! failure of that parser. + #! Not using packrat, so recursion causes data stack overflow + "1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call +] must-fail + +{ V{ 49 } } [ + #! Test direct left recursion. Currently left recursion should cause a + #! failure of that parser. + #! 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 ] with-packrat parse-result-ast +] unit-test + +[ + #! Test indirect left recursion. Currently left recursion should cause a + #! failure of that parser. + #! Not using packrat, so recursion causes data stack overflow + "1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call +] must-fail + +{ V{ 49 } } [ + #! Test indirect left recursion. Currently left recursion should cause a + #! failure of that parser. + #! Using packrat, so first part of expr fails, causing 2nd choice to be used + "1+1" [ [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call ] with-packrat parse-result-ast +] unit-test diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 11e1e2ea64..be4beab3f1 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -266,7 +266,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) ] [ ] make delay sp ; : transform-ebnf ( string -- object ) - 'ebnf' parse parse-result-ast transform ; + 'ebnf' [ parse ] packrat-parse parse-result-ast transform ; : check-parse-result ( result -- result ) dup [ @@ -281,7 +281,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) ] if ; : ebnf>quot ( string -- hashtable quot ) - 'ebnf' parse check-parse-result + 'ebnf' [ parse ] with-packrat check-parse-result parse-result-ast transform dup main swap at compile 1quotation ; : [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index bd8abb63e6..cd95bd3b93 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -179,4 +179,20 @@ IN: peg.tests [ "1+1" swap parse parse-result-ast ] with-packrat -] unit-test \ No newline at end of file +] 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 ; + +[ + #! Not using packrat, so recursion causes data stack overflow + "1+1" expr parse parse-result-ast +] must-fail + +{ "1" } [ + #! Using packrat, so expr fails, causing the 2nd choice to be used. + "1+1" expr [ parse ] with-packrat parse-result-ast +] unit-test + diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 1361f9fdbd..e5632d645c 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -39,7 +39,11 @@ GENERIC: (compile) ( parser -- quot ) #! from the input cache. If the item is not in the cache, #! call 'quot' with 'input' on the stack to get the result #! and store that in the cache and return it. - n input-cache [ drop input quot call ] cache ; inline + n input-cache [ + drop + f n input-cache set-at + input quot call + ] cache ; inline :: run-packrat-parser ( input quot c -- result ) input input-from From fa8b311b277582adbcdf5fe9e6aca747b1cd5322 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 28 Mar 2008 00:04:08 +1300 Subject: [PATCH 235/886] Add packrat-parse, etc --- extra/peg/ebnf/ebnf.factor | 4 ++-- extra/peg/peg-docs.factor | 30 ++++++++++++++++++++++++++---- extra/peg/peg.factor | 10 ++++++++-- 3 files changed, 36 insertions(+), 8 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index be4beab3f1..ed0dea0410 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -266,7 +266,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) ] [ ] make delay sp ; : transform-ebnf ( string -- object ) - 'ebnf' [ parse ] packrat-parse parse-result-ast transform ; + 'ebnf' packrat-parse parse-result-ast transform ; : check-parse-result ( result -- result ) dup [ @@ -281,7 +281,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) ] if ; : ebnf>quot ( string -- hashtable quot ) - 'ebnf' [ parse ] with-packrat check-parse-result + 'ebnf' packrat-parse check-parse-result parse-result-ast transform dup main swap at compile 1quotation ; : [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index 30e7f0e72f..c93d1af830 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -12,7 +12,7 @@ HELP: parse { $description "Given the input string, parse it using the given parser. The result is a object if " "the parse was successful, otherwise it is f." } -{ $see-also compile with-packrat } ; +{ $see-also compile with-packrat packrat-parse } ; HELP: with-packrat { $values @@ -23,8 +23,30 @@ HELP: with-packrat "Calls the quotation with a packrat cache in scope. Usually the quotation will " "call " { $link parse } " or call a word produced by " { $link compile } "." "The cache is used to avoid the possible exponential time performace that pegs " - "can have, instead giving linear time at the cost of increased memory usage." } -{ $see-also compile parse } ; + "can have, instead giving linear time at the cost of increased memory usage. " + "Use of this packrat option also allows direct and indirect recursion to " + "be handled in the parser without entering an infinite loop." } +{ $see-also compile parse packrat-parse packrat-call } ; + +HELP: packrat-parse +{ $values + { "input" "a string" } + { "parser" "a parser" } + { "result" "a parse-result or f" } +} +{ $description + "Compiles and calls the parser with a packrat cache in scope." } +{ $see-also compile parse packrat-call with-packrat } ; + +HELP: packrat-call +{ $values + { "input" "a string" } + { "quot" "a quotation with stack effect ( input -- result )" } + { "result" "a parse-result or f" } +} +{ $description + "Calls the compiled parser with a packrat cache in scope." } +{ $see-also compile packrat-call packrat-parse with-packrat } ; HELP: compile { $values @@ -36,7 +58,7 @@ HELP: compile "The mapping from parser to compiled word is kept in a cache. If you later change " "the definition of a parser you'll need to clear this cache with " { $link reset-compiled-parsers } " before using " { $link compile } " on that parser again." } -{ $see-also compile with-packrat reset-compiled-parsers } ; +{ $see-also compile with-packrat reset-compiled-parsers packrat-call packrat-parse } ; HELP: reset-compiled-parsers { $description diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index e5632d645c..246dbc7962 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -67,11 +67,17 @@ GENERIC: (compile) ( parser -- quot ) [ compiled-parser ] with-compilation-unit ; : parse ( state parser -- result ) - compile execute ; + compile execute ; inline : with-packrat ( quot -- result ) #! Run the quotation with a packrat cache active. - [ H{ } clone packrat ] dip with-variable ; + [ H{ } clone packrat ] dip with-variable ; inline + +: packrat-parse ( state parser -- result ) + [ parse ] with-packrat ; + +: packrat-call ( state quot -- result ) + with-packrat ; inline Date: Thu, 27 Mar 2008 06:27:36 -0500 Subject: [PATCH 236/886] remove random.backend --- extra/bootstrap/random/random.factor | 3 +- extra/random/backend/backend.factor | 24 -------------- extra/random/dummy/dummy.factor | 2 +- .../mersenne-twister-tests.factor | 2 +- .../mersenne-twister/mersenne-twister.factor | 2 +- extra/random/random.factor | 33 +++++++++++-------- extra/random/unix/unix.factor | 2 +- extra/random/windows/windows.factor | 3 +- 8 files changed, 27 insertions(+), 44 deletions(-) delete mode 100755 extra/random/backend/backend.factor diff --git a/extra/bootstrap/random/random.factor b/extra/bootstrap/random/random.factor index b61e002526..b22ee27ebf 100755 --- a/extra/bootstrap/random/random.factor +++ b/extra/bootstrap/random/random.factor @@ -1,6 +1,6 @@ USING: vocabs.loader sequences system random random.mersenne-twister combinators init -namespaces ; +namespaces random.backend ; "random.mersenne-twister" require @@ -9,5 +9,6 @@ namespaces ; { [ unix? ] [ "random.unix" require ] } } cond +! [ [ 32 random-bits ] with-secure-random random-generator set-global ] [ millis random-generator set-global ] "generator.random" add-init-hook diff --git a/extra/random/backend/backend.factor b/extra/random/backend/backend.factor deleted file mode 100755 index c5243c22bd..0000000000 --- a/extra/random/backend/backend.factor +++ /dev/null @@ -1,24 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel math namespaces sequences -io.backend io.binary combinators system vocabs.loader ; -IN: random.backend - -SYMBOL: insecure-random-generator -SYMBOL: secure-random-generator -SYMBOL: random-generator - -GENERIC: seed-random ( tuple seed -- ) -GENERIC: random-32* ( tuple -- r ) -GENERIC: random-bytes* ( n tuple -- bytes ) - -M: object random-bytes* ( n tuple -- byte-array ) - swap [ drop random-32* ] with map >c-uint-array ; - -M: object random-32* ( tuple -- n ) 4 random-bytes* le> ; - -ERROR: no-random-number-generator ; - -M: f random-bytes* ( n obj -- * ) no-random-number-generator ; - -M: f random-32* ( obj -- * ) no-random-number-generator ; diff --git a/extra/random/dummy/dummy.factor b/extra/random/dummy/dummy.factor index a17ef54982..e0cb83c330 100755 --- a/extra/random/dummy/dummy.factor +++ b/extra/random/dummy/dummy.factor @@ -1,4 +1,4 @@ -USING: kernel random math accessors random.backend ; +USING: kernel random math accessors random ; IN: random.dummy TUPLE: random-dummy i ; diff --git a/extra/random/mersenne-twister/mersenne-twister-tests.factor b/extra/random/mersenne-twister/mersenne-twister-tests.factor index 9eb546063e..703a0c16e4 100755 --- a/extra/random/mersenne-twister/mersenne-twister-tests.factor +++ b/extra/random/mersenne-twister/mersenne-twister-tests.factor @@ -1,5 +1,5 @@ USING: kernel math random namespaces random.mersenne-twister -sequences tools.test random.backend ; +sequences tools.test ; IN: random.mersenne-twister.tests : check-random ( max -- ? ) diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index 4eb93f2941..331ae9af82 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -5,7 +5,7 @@ USING: arrays kernel math namespaces sequences system init accessors math.ranges combinators.cleave new-effects -random.backend ; +random ; IN: random.mersenne-twister c-uint-array ; + +M: object random-32* ( tuple -- n ) 4 random-bytes* le> ; + +ERROR: no-random-number-generator ; + +M: f random-bytes* ( n obj -- * ) no-random-number-generator ; + +M: f random-32* ( obj -- * ) no-random-number-generator ; + : random-bytes ( n -- r ) [ dup 4 rem zero? [ 1+ ] unless @@ -29,13 +46,3 @@ IN: random : with-secure-random ( quot -- ) >r secure-random-generator get r> with-random ; inline - -{ - { [ windows? ] [ "random.windows" require ] } - { [ unix? ] [ "random.unix" require ] } -} cond - -[ - [ 32 random-bits ] with-secure-random - random-generator set-global -] "random" add-init-hook diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor index 78765bc575..51574887e3 100644 --- a/extra/random/unix/unix.factor +++ b/extra/random/unix/unix.factor @@ -1,5 +1,5 @@ USING: alien.c-types io io.files io.nonblocking kernel -namespaces random.backend io.encodings.binary singleton init +namespaces random io.encodings.binary singleton init accessors ; IN: random.unix diff --git a/extra/random/windows/windows.factor b/extra/random/windows/windows.factor index ef0d10059e..e0c564bc2c 100644 --- a/extra/random/windows/windows.factor +++ b/extra/random/windows/windows.factor @@ -1,6 +1,5 @@ USING: accessors alien.c-types byte-arrays continuations -kernel windows windows.advapi32 init namespaces -random.backend ; +kernel windows windows.advapi32 init namespaces random ; IN: random.windows TUPLE: windows-crypto-context handle ; From f317b97221099653cc805dbda36457d19e70b77c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Mar 2008 06:30:59 -0500 Subject: [PATCH 237/886] stack effect typos --- extra/random/random.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/random/random.factor b/extra/random/random.factor index 56590adb91..e62ab71b92 100755 --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -10,7 +10,7 @@ SYMBOL: random-generator GENERIC: seed-random ( tuple seed -- ) GENERIC: random-32* ( tuple -- r ) -GENERIC: random-bytes* ( n tuple -- bytes ) +GENERIC: random-bytes* ( n tuple -- byte-array ) M: object random-bytes* ( n tuple -- byte-array ) swap [ drop random-32* ] with map >c-uint-array ; @@ -23,7 +23,7 @@ M: f random-bytes* ( n obj -- * ) no-random-number-generator ; M: f random-32* ( obj -- * ) no-random-number-generator ; -: random-bytes ( n -- r ) +: random-bytes ( n -- byte-array ) [ dup 4 rem zero? [ 1+ ] unless random-generator get random-bytes* From 251fe256891ed44501e821f36e382647876d3719 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Mar 2008 06:36:34 -0500 Subject: [PATCH 238/886] fix bootstrap for random --- extra/bootstrap/random/random.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/bootstrap/random/random.factor b/extra/bootstrap/random/random.factor index b22ee27ebf..daf35b9c03 100755 --- a/extra/bootstrap/random/random.factor +++ b/extra/bootstrap/random/random.factor @@ -1,6 +1,6 @@ USING: vocabs.loader sequences system random random.mersenne-twister combinators init -namespaces random.backend ; +namespaces random ; "random.mersenne-twister" require From b6818e75f492f89d8fcb8f156fba5a339876763b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Mar 2008 16:22:24 -0500 Subject: [PATCH 239/886] cleanup windows normalize-path --- core/io/files/files-tests.factor | 6 +++ core/io/files/files.factor | 4 ++ extra/io/windows/nt/files/files-tests.factor | 48 ++++++++++++++--- extra/io/windows/nt/files/files.factor | 55 +++++++------------- 4 files changed, 69 insertions(+), 44 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 9af82a5672..b732495541 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -89,6 +89,12 @@ io.encodings.utf8 ; ] 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 diff --git a/core/io/files/files.factor b/core/io/files/files.factor index f6888bf78d..3ebde42b96 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -173,8 +173,12 @@ M: object cwd ( -- path ) "." ; [ cwd current-directory set-global ] "current-directory" add-init-hook : with-directory ( path quot -- ) + >r normalize-pathname r> current-directory swap with-variable ; inline +: set-current-directory ( path -- ) + normalize-pathname current-directory set ; + ! Creating directories HOOK: make-directory io-backend ( path -- ) diff --git a/extra/io/windows/nt/files/files-tests.factor b/extra/io/windows/nt/files/files-tests.factor index 3b31d73e4a..73d6a0bf7f 100644 --- a/extra/io/windows/nt/files/files-tests.factor +++ b/extra/io/windows/nt/files/files-tests.factor @@ -1,15 +1,47 @@ -USING: kernel tools.test ; +USING: io.files kernel tools.test io.backend +io.windows.nt.files splitting ; IN: io.windows.nt.files.tests -[ 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 ] [ "//" root-directory? ] unit-test -[ t ] [ "//////////////" root-directory? ] unit-test [ t ] [ "\\foo" absolute-path? ] unit-test [ t ] [ "\\\\?\\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 + +[ ] [ "" 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" append-path normalize-pathname +] unit-test + +[ "\\\\?\\C:\\builds\\" ] [ + "C:\\builds\\factor\\12345\\" + "..\\.." append-path normalize-pathname +] unit-test + +[ "\\\\?\\C:\\builds\\" ] [ + "C:\\builds\\factor\\12345\\" + "..\\.." append-path normalize-pathname +] unit-test diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index c6cbf292b3..24111346b6 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -18,12 +18,15 @@ M: windows-nt-io cd "\\\\?\\" ; inline M: windows-nt-io root-directory? ( path -- ? ) - dup length 2 = [ - first2 - [ Letter? ] [ CHAR: : = ] bi* and - ] [ - drop f - ] if ; + { + { [ dup empty? ] [ f ] } + { [ dup [ path-separator? ] all? ] [ t ] } + { [ dup right-trim-separators + { [ dup length 2 = ] [ dup second CHAR: : = ] } && nip ] [ + t + ] } + { [ t ] [ f ] } + } cond nip ; ERROR: not-absolute-path ; : root-directory ( string -- string' ) @@ -36,45 +39,25 @@ ERROR: not-absolute-path ; : prepend-prefix ( string -- string' ) unicode-prefix prepend ; -: windows-append-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-append-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 ; - ERROR: nonstring-pathname ; ERROR: empty-pathname ; -USE: tools.walker M: windows-nt-io normalize-pathname ( string -- string ) "resource:" ?head [ left-trim-separators resource-path normalize-pathname ] [ - dup string? [ nonstring-pathname ] unless dup empty? [ empty-pathname ] when - { { CHAR: / CHAR: \\ } } substitute - current-directory get swap windows-append-path - [ "/\\." member? ] right-trim - dup peek CHAR: : = [ "\\" append ] when + current-directory get prepend-path + dup unicode-prefix head? [ + dup first path-separator? [ + left-trim-separators + current-directory get 2 head + prepend-path + ] when + unicode-prefix prepend + ] unless + { { CHAR: / CHAR: \\ } } substitute ! necessary ] if ; M: windows-nt-io CreateFile-flags ( DWORD -- DWORD ) From af28c3376d1e151578cb4e2bcb9dcaf3d94903c4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 16:24:38 -0500 Subject: [PATCH 240/886] Fix PowerPC intrinsic --- core/cpu/ppc/intrinsics/intrinsics.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 8a2f41ec12..0aef15ba99 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -481,7 +481,7 @@ IN: cpu.ppc.intrinsics \ [ tuple "layout" get layout-size 2 + cells %allot ! Store layout - "layout" operand 12 LOAD32 + "layout" get 12 load-indirect 12 11 cell STW ! Zero out the rest of the tuple f v>operand 12 LI From 89c76987388ad917247caed9f618c2253dfeb5da Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 28 Mar 2008 11:30:46 +1300 Subject: [PATCH 241/886] Fix MEMO problem with seq* and choice* --- extra/peg/peg.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 246dbc7962..709052b7dd 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -338,7 +338,7 @@ MEMO: 3seq ( parser1 parser2 parser3 -- parser ) MEMO: 4seq ( parser1 parser2 parser3 parser4 -- parser ) 4array seq ; -MEMO: seq* ( quot -- paser ) +: seq* ( quot -- paser ) { } make seq ; inline MEMO: choice ( seq -- parser ) @@ -353,7 +353,7 @@ MEMO: 3choice ( parser1 parser2 parser3 -- parser ) MEMO: 4choice ( parser1 parser2 parser3 parser4 -- parser ) 4array choice ; -MEMO: choice* ( quot -- paser ) +: choice* ( quot -- paser ) { } make choice ; inline MEMO: repeat0 ( parser -- parser ) From 146bdbccbbd12609c165017dac84ddd3bb854f5b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Mar 2008 17:43:00 -0500 Subject: [PATCH 242/886] fix rng on windows --- extra/random/windows/windows.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/random/windows/windows.factor b/extra/random/windows/windows.factor index cd69105e65..65426d4277 100644 --- a/extra/random/windows/windows.factor +++ b/extra/random/windows/windows.factor @@ -46,9 +46,9 @@ M: windows-rng random-bytes* ( n tuple -- bytes ) MS_DEF_PROV PROV_RSA_FULL insecure-random-generator set-global - ! MS_STRONG_PROV - ! PROV_RSA_FULL secure-random-generator set-global + MS_STRONG_PROV + PROV_RSA_FULL secure-random-generator set-global - MS_ENH_RSA_AES_PROV - PROV_RSA_AES secure-random-generator set-global + ! MS_ENH_RSA_AES_PROV + ! PROV_RSA_AES secure-random-generator set-global ] "random.windows" add-init-hook From f96a251f8a1bdae231e4bc87fc7310a3e72e6b7e Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 28 Mar 2008 12:00:36 +1300 Subject: [PATCH 243/886] Refactor pegs to remove MEMO: and use unique id's --- extra/peg/parsers/parsers.factor | 3 +- extra/peg/peg.factor | 139 +++++++++++++++++++------------ 2 files changed, 85 insertions(+), 57 deletions(-) diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index fa6801dc1c..7a82418c27 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -7,7 +7,6 @@ USING: kernel sequences strings namespaces math assocs shuffle IN: peg.parsers TUPLE: just-parser p1 ; -M: just-parser equal? 2drop f ; : just-pattern [ @@ -21,7 +20,7 @@ M: just-parser (compile) ( parser -- quot ) just-parser-p1 compiled-parser just-pattern curry ; MEMO: just ( parser -- parser ) - just-parser construct-boa ; + just-parser construct-boa init-parser ; : 1token ( ch -- parser ) 1string token ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 709052b7dd..eadbe2528f 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -29,25 +29,24 @@ GENERIC: (compile) ( parser -- quot ) #! input slice is based on. dup slice? [ slice-from ] [ drop 0 ] if ; -: input-cache ( quot cache -- cache ) +: input-cache ( id -- cache ) #! From the packrat cache, obtain the cache for the parser quotation #! that maps the input string position to the parser result. - [ drop H{ } clone ] cache ; + packrat get [ drop H{ } clone ] cache ; -:: cached-result ( n input-cache input quot -- result ) - #! Get the cached result for input position n +:: cached-result ( input-cache input quot -- result ) + #! Get the cached result for input position #! from the input cache. If the item is not in the cache, #! call 'quot' with 'input' on the stack to get the result #! and store that in the cache and return it. - n input-cache [ + input input-from input-cache [ drop - f n input-cache set-at + f input input-from input-cache set-at input quot call ] cache ; inline -:: run-packrat-parser ( input quot c -- result ) - input input-from - quot c input-cache +:: run-packrat-parser ( input quot id -- result ) + id input-cache input quot cached-result ; inline : run-parser ( input quot -- result ) @@ -55,12 +54,28 @@ GENERIC: (compile) ( parser -- quot ) #! packrat parsing, otherwise do a standard peg call. packrat get [ run-packrat-parser ] [ call ] if* ; inline +:: parser-body ( parser -- quot ) + #! Return the body of the word that is the compiled version + #! of the parser. + [let* | parser-quot [ parser (compile) ] + id [ parser id>> ] + | + [ + packrat get [ + parser-quot id run-packrat-parser + ] [ + parser-quot call + ] if + ] + ] ; + : 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. compiled-parsers [ - (compile) [ run-parser ] curry define-temp + dup parser-body define-temp + tuck swap "peg" set-word-prop ] cache ; : compile ( parser -- word ) @@ -81,8 +96,34 @@ GENERIC: (compile) ( parser -- quot ) > ] 2apply = ; +C: parser + +: delegates ( -- cache ) + \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ; + +: reset-delegates ( -- ) + H{ } clone \ delegates set-global ; + +: 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 + ] cache over set-delegate ; + TUPLE: token-parser symbol ; -M: token-parser equal? 2drop f ; MATCH-VARS: ?token ; @@ -98,7 +139,6 @@ M: token-parser (compile) ( parser -- quot ) symbol>> [ parse-token ] curry ; TUPLE: satisfy-parser quot ; -M: satisfy-parser equal? 2drop f ; MATCH-VARS: ?quot ; @@ -119,7 +159,6 @@ M: satisfy-parser (compile) ( parser -- quot ) quot>> \ ?quot satisfy-pattern match-replace ; TUPLE: range-parser min max ; -M: range-parser equal? 2drop f ; MATCH-VARS: ?min ?max ; @@ -141,7 +180,6 @@ M: range-parser (compile) ( parser -- quot ) T{ range-parser _ ?min ?max } range-pattern match-replace ; TUPLE: seq-parser parsers ; -M: seq-parser equal? 2drop f ; : seq-pattern ( -- quot ) [ @@ -168,7 +206,6 @@ M: seq-parser (compile) ( parser -- quot ) ] [ ] make ; TUPLE: choice-parser parsers ; -M: choice-parser equal? 2drop f ; : choice-pattern ( -- quot ) [ @@ -187,7 +224,6 @@ M: choice-parser (compile) ( parser -- quot ) ] [ ] make ; TUPLE: repeat0-parser p1 ; -M: repeat0-parser equal? 2drop f ; : (repeat0) ( quot result -- result ) 2dup remaining>> swap call [ @@ -210,7 +246,6 @@ M: repeat0-parser (compile) ( parser -- quot ) ] [ ] make ; TUPLE: repeat1-parser p1 ; -M: repeat1-parser equal? 2drop f ; : repeat1-pattern ( -- quot ) [ @@ -230,7 +265,6 @@ M: repeat1-parser (compile) ( parser -- quot ) ] [ ] make ; TUPLE: optional-parser p1 ; -M: optional-parser equal? 2drop f ; : optional-pattern ( -- quot ) [ @@ -241,7 +275,6 @@ M: optional-parser (compile) ( parser -- quot ) p1>> compiled-parser \ ?quot optional-pattern match-replace ; TUPLE: ensure-parser p1 ; -M: ensure-parser equal? 2drop f ; : ensure-pattern ( -- quot ) [ @@ -256,7 +289,6 @@ M: ensure-parser (compile) ( parser -- quot ) p1>> compiled-parser \ ?quot ensure-pattern match-replace ; TUPLE: ensure-not-parser p1 ; -M: ensure-not-parser equal? 2drop f ; : ensure-not-pattern ( -- quot ) [ @@ -271,7 +303,6 @@ M: ensure-not-parser (compile) ( parser -- quot ) p1>> compiled-parser \ ?quot ensure-not-pattern match-replace ; TUPLE: action-parser p1 quot ; -M: action-parser equal? 2drop f ; MATCH-VARS: ?action ; @@ -295,7 +326,6 @@ M: action-parser (compile) ( parser -- quot ) ] unless ; TUPLE: sp-parser p1 ; -M: sp-parser equal? 2drop f ; M: sp-parser (compile) ( parser -- quot ) [ @@ -303,7 +333,6 @@ M: sp-parser (compile) ( parser -- quot ) ] [ ] make ; TUPLE: delay-parser quot ; -M: delay-parser equal? 2drop f ; M: delay-parser (compile) ( parser -- quot ) #! For efficiency we memoize the quotation. @@ -317,71 +346,71 @@ M: delay-parser (compile) ( parser -- quot ) PRIVATE> -MEMO: token ( string -- parser ) - token-parser construct-boa ; +: token ( string -- parser ) + token-parser construct-boa init-parser ; -MEMO: satisfy ( quot -- parser ) - satisfy-parser construct-boa ; +: satisfy ( quot -- parser ) + satisfy-parser construct-boa init-parser ; -MEMO: range ( min max -- parser ) - range-parser construct-boa ; +: range ( min max -- parser ) + range-parser construct-boa init-parser ; -MEMO: seq ( seq -- parser ) - seq-parser construct-boa ; +: seq ( seq -- parser ) + seq-parser construct-boa init-parser ; -MEMO: 2seq ( parser1 parser2 -- parser ) +: 2seq ( parser1 parser2 -- parser ) 2array seq ; -MEMO: 3seq ( parser1 parser2 parser3 -- parser ) +: 3seq ( parser1 parser2 parser3 -- parser ) 3array seq ; -MEMO: 4seq ( parser1 parser2 parser3 parser4 -- parser ) +: 4seq ( parser1 parser2 parser3 parser4 -- parser ) 4array seq ; : seq* ( quot -- paser ) { } make seq ; inline -MEMO: choice ( seq -- parser ) - choice-parser construct-boa ; +: choice ( seq -- parser ) + choice-parser construct-boa init-parser ; -MEMO: 2choice ( parser1 parser2 -- parser ) +: 2choice ( parser1 parser2 -- parser ) 2array choice ; -MEMO: 3choice ( parser1 parser2 parser3 -- parser ) +: 3choice ( parser1 parser2 parser3 -- parser ) 3array choice ; -MEMO: 4choice ( parser1 parser2 parser3 parser4 -- parser ) +: 4choice ( parser1 parser2 parser3 parser4 -- parser ) 4array choice ; : choice* ( quot -- paser ) { } make choice ; inline -MEMO: repeat0 ( parser -- parser ) - repeat0-parser construct-boa ; +: repeat0 ( parser -- parser ) + repeat0-parser construct-boa init-parser ; -MEMO: repeat1 ( parser -- parser ) - repeat1-parser construct-boa ; +: repeat1 ( parser -- parser ) + repeat1-parser construct-boa init-parser ; -MEMO: optional ( parser -- parser ) - optional-parser construct-boa ; +: optional ( parser -- parser ) + optional-parser construct-boa init-parser ; -MEMO: ensure ( parser -- parser ) - ensure-parser construct-boa ; +: ensure ( parser -- parser ) + ensure-parser construct-boa init-parser ; -MEMO: ensure-not ( parser -- parser ) - ensure-not-parser construct-boa ; +: ensure-not ( parser -- parser ) + ensure-not-parser construct-boa init-parser ; -MEMO: action ( parser quot -- parser ) - action-parser construct-boa ; +: action ( parser quot -- parser ) + action-parser construct-boa init-parser ; -MEMO: sp ( parser -- parser ) - sp-parser construct-boa ; +: sp ( parser -- parser ) + sp-parser construct-boa init-parser ; : hide ( parser -- parser ) [ drop ignore ] action ; -MEMO: delay ( quot -- parser ) - delay-parser construct-boa ; +: delay ( quot -- parser ) + delay-parser construct-boa init-parser ; : PEG: (:) [ From 36f51b46f252ba639264f3c3fc40e7374f5459a0 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 27 Mar 2008 19:06:24 -0500 Subject: [PATCH 244/886] fix ultraedit --- extra/editors/ultraedit/ultraedit.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/editors/ultraedit/ultraedit.factor b/extra/editors/ultraedit/ultraedit.factor index 1fef9f3350..d0bb789c1b 100755 --- a/extra/editors/ultraedit/ultraedit.factor +++ b/extra/editors/ultraedit/ultraedit.factor @@ -5,7 +5,7 @@ IN: editors.ultraedit : ultraedit-path ( -- path ) \ ultraedit-path get-global [ program-files - "\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" append-path + "IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" append-path ] unless* ; : ultraedit ( file line -- ) From 7ad1686590d5f27ba0ac09e835c1d317c0872ea2 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 27 Mar 2008 20:50:41 -0400 Subject: [PATCH 245/886] Factoring out parse-unit --- core/parser/parser.factor | 4 ++++ core/syntax/syntax.factor | 4 +--- extra/help/syntax/syntax.factor | 4 +--- extra/tuple-syntax/tuple-syntax.factor | 5 +---- 4 files changed, 7 insertions(+), 10 deletions(-) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index f6e351a42e..1e66618053 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -366,6 +366,10 @@ ERROR: bad-number ; : (M:) CREATE-METHOD parse-definition ; +: parse-unit ( -- object ) + scan-word dup parsing? + [ V{ } clone swap execute first ] when ; + GENERIC: expected>string ( obj -- str ) M: f expected>string drop "end of input" ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 9190b9676d..778a9e7293 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -171,9 +171,7 @@ IN: bootstrap.syntax ] define-syntax "FORGET:" [ - scan-word - dup parsing? [ V{ } clone swap execute first ] when - forget + parse-unit forget ] define-syntax "(" [ diff --git a/extra/help/syntax/syntax.factor b/extra/help/syntax/syntax.factor index e006a9816b..d41b72ee20 100755 --- a/extra/help/syntax/syntax.factor +++ b/extra/help/syntax/syntax.factor @@ -16,6 +16,4 @@ IN: help.syntax 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 + parse-unit in get vocab set-vocab-help ; parsing diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor index f06bb55899..fe05e5a374 100755 --- a/extra/tuple-syntax/tuple-syntax.factor +++ b/extra/tuple-syntax/tuple-syntax.factor @@ -5,9 +5,6 @@ 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 object-slots slot-named slot-spec-offset @@ -15,7 +12,7 @@ IN: tuple-syntax : parse-slots ( accum tuple -- accum tuple ) dup parse-slot-writer - [ parse-object pick rot set-slot parse-slots ] when* ; + [ parse-unit pick rot set-slot parse-slots ] when* ; : TUPLE{ scan-word construct-empty parse-slots parsed ; parsing From 31de812987eeb9c9ef977e230a01481c2aa1ed57 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 27 Mar 2008 20:52:53 -0400 Subject: [PATCH 246/886] renaming parse-unit to scan-until --- core/parser/parser.factor | 2 +- core/syntax/syntax.factor | 2 +- extra/help/syntax/syntax.factor | 2 +- extra/tuple-syntax/tuple-syntax.factor | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 1e66618053..08f4275e49 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -366,7 +366,7 @@ ERROR: bad-number ; : (M:) CREATE-METHOD parse-definition ; -: parse-unit ( -- object ) +: scan-object ( -- object ) scan-word dup parsing? [ V{ } clone swap execute first ] when ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 778a9e7293..5da2d5e4e2 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -171,7 +171,7 @@ IN: bootstrap.syntax ] define-syntax "FORGET:" [ - parse-unit forget + scan-object forget ] define-syntax "(" [ diff --git a/extra/help/syntax/syntax.factor b/extra/help/syntax/syntax.factor index d41b72ee20..9450f87215 100755 --- a/extra/help/syntax/syntax.factor +++ b/extra/help/syntax/syntax.factor @@ -16,4 +16,4 @@ IN: help.syntax over add-article >link r> remember-definition ; parsing : ABOUT: - parse-unit in get vocab set-vocab-help ; parsing + scan-object in get vocab set-vocab-help ; parsing diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor index fe05e5a374..2419b8febb 100755 --- a/extra/tuple-syntax/tuple-syntax.factor +++ b/extra/tuple-syntax/tuple-syntax.factor @@ -12,7 +12,7 @@ IN: tuple-syntax : parse-slots ( accum tuple -- accum tuple ) dup parse-slot-writer - [ parse-unit 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 From 6019713ee1d7142bac773f3b393b9f7004bdaf93 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 19:57:16 -0500 Subject: [PATCH 247/886] Tweak --- extra/tools/vocabs/vocabs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index d7c3d2be20..d7610c21c8 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -206,7 +206,7 @@ MEMO: all-vocabs-seq ( -- seq ) { [ "editors." ?head ] [ t ] } { [ ".windows" ?tail ] [ t ] } { [ ".unix" ?tail ] [ t ] } - { [ "unix." ?head ] [ t ] } + { [ "unix" ?head ] [ t ] } { [ ".linux" ?tail ] [ t ] } { [ ".bsd" ?tail ] [ t ] } { [ ".macosx" ?tail ] [ t ] } From 17ba5aa2ef2db84eb5416cd4343890c292e20000 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Mar 2008 20:10:16 -0500 Subject: [PATCH 248/886] use resource: --- core/io/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 3ebde42b96..2b546bdee4 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -276,7 +276,7 @@ DEFER: copy-tree-into prepend-path ; : temp-directory ( -- path ) - "temp" resource-path dup make-directories ; + "resource:temp" dup make-directories ; : temp-file ( name -- path ) temp-directory prepend-path ; From f596aa2d71f1f6dba6b94304b9754e83afde43fc Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 28 Mar 2008 14:10:33 +1300 Subject: [PATCH 249/886] Handle compilation of circular parsers --- extra/peg/peg-tests.factor | 8 +++++++- extra/peg/peg.factor | 12 ++++++++---- 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index cd95bd3b93..7e2701bc48 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -1,7 +1,7 @@ ! 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 ; IN: peg.tests { f } [ @@ -196,3 +196,9 @@ IN: peg.tests "1+1" expr [ parse ] with-packrat 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 \ No newline at end of file diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index eadbe2528f..9db23d9779 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -73,10 +73,14 @@ GENERIC: (compile) ( parser -- quot ) #! 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. - compiled-parsers [ - dup parser-body define-temp - tuck swap "peg" set-word-prop - ] cache ; + #! 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 id>> compiled-parsers [ + drop dup gensym swap 2dup id>> compiled-parsers set-at + 2dup parser-body define + dupd "peg" set-word-prop + ] cache nip ; : compile ( parser -- word ) [ compiled-parser ] with-compilation-unit ; From 749f10ba9fd39954e1d2162ae10ec91880b23921 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 28 Mar 2008 00:50:46 +1300 Subject: [PATCH 250/886] Implement direct left recursion As per VPRI Technical Report TR-2007-002 section 3.2 --- extra/peg/peg.factor | 49 +++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 46 insertions(+), 3 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 9db23d9779..f93fd5ae9b 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -34,16 +34,59 @@ GENERIC: (compile) ( parser -- quot ) #! that maps the input string position to the parser result. packrat get [ drop H{ } clone ] cache ; +TUPLE: left-recursion detected? ; +C: left-recursion + +USE: prettyprint + +:: handle-left-recursive-result ( result -- result ) + #! If the result is from a left-recursive call, + #! note this and fail, otherwise return normal result + #! See figure 4 of packrat_TR-2007-002.pdf. + result [ + [let* | ast [ result ast>> ] | + ast left-recursion? [ t ast (>>detected?) f ] [ result ] if + ] + ] [ + f + ] if ; + +USE: io + +:: grow-lr ( input quot m -- result ) + #! 'Grow the Seed' algorithm to handle left recursion + [let* | ans [ input quot call ] | + [ ans not ] [ ans [ ans remaining>> input-from m remaining>> input-from <= ] [ f ] if ] 2array || [ + "recursion exiting with = " write ans . "m was " write m . + ans + ] [ + "recursion with = " write ans . + input quot ans grow-lr + ] if + ] ; + :: cached-result ( input-cache input quot -- result ) #! Get the cached result for input position #! from the input cache. If the item is not in the cache, #! call 'quot' with 'input' on the stack to get the result #! and store that in the cache and return it. + #! See figure 4 of packrat_TR-2007-002.pdf. + "cached-result " write input . "quot is " write quot . input input-from input-cache [ drop - f input input-from input-cache set-at - input quot call - ] cache ; inline + [let* | lr [ f ] + m [ input lr ] + ans [ m input input-from input-cache set-at input quot call ] + | + lr detected?>> ans and [ + input quot ans grow-lr + ] [ + ans + ] if + ] + ] cache + "found in cache: " write dup . "for quot " write quot . + handle-left-recursive-result "after handle " write dup . ; :: run-packrat-parser ( input quot id -- result ) id input-cache From d2190fd1ecdfc7c6f3a261b35dc0959a5ac863ac Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 28 Mar 2008 13:40:26 +1300 Subject: [PATCH 251/886] Direct left recurson working --- extra/peg/peg.factor | 36 +++++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index f93fd5ae9b..84ccefdf35 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -38,23 +38,26 @@ TUPLE: left-recursion detected? ; C: left-recursion USE: prettyprint +USE: io + :: handle-left-recursive-result ( result -- result ) #! If the result is from a left-recursive call, #! note this and fail, otherwise return normal result #! See figure 4 of packrat_TR-2007-002.pdf. + ">>handle-left-recursive-result " write result . result [ [let* | ast [ result ast>> ] | ast left-recursion? [ t ast (>>detected?) f ] [ result ] if ] ] [ f - ] if ; + ] if + "<>grow-lr " write input . " for parser " write parser . " m is " write m . [let* | ans [ input quot call ] | [ ans not ] [ ans [ ans remaining>> input-from m remaining>> input-from <= ] [ f ] if ] 2array || [ "recursion exiting with = " write ans . "m was " write m . @@ -63,34 +66,38 @@ USE: io "recursion with = " write ans . input quot ans grow-lr ] if - ] ; + ] + "<>cached-result " write input . " for parser " write parser . input input-from input-cache [ drop [let* | lr [ f ] m [ input lr ] ans [ m input input-from input-cache set-at input quot call ] | + "--lr is " write lr . " ans is " write ans . " for parser " write parser . + ans input input-from input-cache set-at lr detected?>> ans and [ - input quot ans grow-lr + input quot parser ans grow-lr ] [ ans ] if ] ] cache - "found in cache: " write dup . "for quot " write quot . - handle-left-recursive-result "after handle " write dup . ; + dup [ handle-left-recursive-result ] when + "<> input-cache + input quot parser cached-result ; inline : run-parser ( input quot -- result ) #! If a packrat cache is available, use memoization for @@ -101,11 +108,10 @@ USE: io #! Return the body of the word that is the compiled version #! of the parser. [let* | parser-quot [ parser (compile) ] - id [ parser id>> ] | [ packrat get [ - parser-quot id run-packrat-parser + parser-quot parser run-packrat-parser ] [ parser-quot call ] if From 248c88554edcfc8d3f210f8169b38d9f8cbbdfa1 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 27 Mar 2008 22:18:43 -0600 Subject: [PATCH 252/886] builder.release: update 'common-files' --- extra/builder/release/release.factor | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index bb0d16c9da..d76eda8013 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -20,21 +20,15 @@ IN: builder.release "boot.x86.32.image" "boot.x86.64.image" "boot.macosx-ppc.image" + "boot.linux-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" + "build-support" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 0934473b72adf14c3c53f8b78996d70fd8926b98 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 27 Mar 2008 22:22:19 -0600 Subject: [PATCH 253/886] builder: cd changed --- extra/builder/builder.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 19734a3266..461d951209 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -13,6 +13,12 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! : cd ( path -- ) current-directory set ; + +: cd ( path -- ) set-current-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : prepare-build-machine ( -- ) builds make-directory builds cd From bbd1ac71808d72520eed014ab08abfd5e4df2c75 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Mar 2008 01:22:51 -0500 Subject: [PATCH 254/886] Fix launchers --- extra/io/unix/launcher/launcher.factor | 2 +- extra/io/windows/launcher/launcher.factor | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 1292f2cacf..f738bd42c2 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -70,7 +70,7 @@ USE: unix [ setup-priority setup-redirection - current-directory get cd + current-directory get resource-path cd dup pass-environment? [ dup get-environment set-os-envs ] when diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 84f8360840..31247e43c3 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -23,12 +23,12 @@ TUPLE: CreateProcess-args : default-CreateProcess-args ( -- obj ) CreateProcess-args construct-empty - 0 >>dwCreateFlags "STARTUPINFO" "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo "PROCESS_INFORMATION" >>lpProcessInformation TRUE >>bInheritHandles - current-directory get >>lpCurrentDirectory ; + 0 >>dwCreateFlags + current-directory get normalize-pathname >>lpCurrentDirectory ; : call-CreateProcess ( CreateProcess-args -- ) { From 1d87e513f554df459c449a9b7de94788e72c7ab4 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 28 Mar 2008 15:51:18 +1300 Subject: [PATCH 255/886] lr2 wip --- extra/peg/peg.factor | 162 +++++++++++++++++++++++++++++++++++++------ 1 file changed, 140 insertions(+), 22 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 84ccefdf35..96fe36f85f 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -15,6 +15,19 @@ SYMBOL: ignore parse-result construct-boa ; SYMBOL: packrat +SYMBOL: lrstack + +TUPLE: phead rule involved-set eval-set ; +C: phead + +: 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 ; + +: heads ( input -- h ) + input-from \ heads get at ; + : compiled-parsers ( -- cache ) \ compiled-parsers get-global [ H{ } clone dup \ compiled-parsers set-global ] unless* ; @@ -24,17 +37,12 @@ SYMBOL: packrat GENERIC: (compile) ( parser -- quot ) -: 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 ; - : input-cache ( id -- cache ) #! From the packrat cache, obtain the cache for the parser quotation #! that maps the input string position to the parser result. packrat get [ drop H{ } clone ] cache ; -TUPLE: left-recursion detected? ; +TUPLE: left-recursion seed rule head next ; C: left-recursion USE: prettyprint @@ -54,22 +62,138 @@ USE: io f ] if "<>grow-lr " write input . " for parser " write parser . " m is " write m . - [let* | ans [ input quot call ] | - [ ans not ] [ ans [ ans remaining>> input-from m remaining>> input-from <= ] [ f ] if ] 2array || [ + ">>(grow-lr) " write input . " for parser " write parser . " m is " write m . + [let* | + pos [ input ] + ans [ h involved-set>> clone h (>>eval-set) input quot call ] + | + [ ans not ] [ ans [ pos input-from m remaining>> input-from <= ] [ f ] if ] 2array || [ "recursion exiting with = " write ans . "m was " write m . - ans + m ] [ "recursion with = " write ans . - input quot ans grow-lr + pos quot parser pos ans ast>> h (grow-lr) ] if ] - "<> input-cache at* [ drop not-found ] unless ; + + +:: involved? ( parser h -- ? ) + h rule>> parser = [ + t + ] [ + parser h involved-set>> member? + ] if ; + +:: recall ( input quot parser -- result ) + [let* | + m [ parser input memo ] + h [ input heads ] + | + #! If not growing a seed pass, just return what is stored + #! in the memo table. + h [ + m not-found = parser h involved? not and [ + f + ] [ + parser h eval-set>> member? [ + parser h eval-set>> remove h (>>eval-set) + input quot call + ] [ + m + ] if + ] if + ] [ + m + ] if + ] ; + +:: (setup-lr) ( parser l s -- ) + s head>> l head>> = [ + l head>> s (>>head) + l head>> [ s rule>> add ] change-involved-set drop + parser l s next>> (setup-lr) + ] unless ; + +:: setup-lr ( parser l -- ) + [let* | + s [ lrstack get ] + | + l head>> [ parser V{ } clone V{ } clone l (>>head) ] unless + parser l s (setup-lr) + ] ; + +:: lr-answer ( quot parser input m -- result ) + [let* | + h [ m ast>> head>> ] + | + h rule>> parser = [ + "changing memo ast to seed " write + m [ seed>> ast>> dup . ] change-ast drop + m input input-from parser id>> input-cache set-at + m ast>> not [ + f + ] [ + input quot parser m h grow-lr + ] if + ] [ + m ast>> seed>> + ] if + ] ; + +:: (apply-rule) ( quot parser input -- result ) + [let* | + lr [ f parser f lrstack get ] + m [ lr lrstack set input lr ] + ans [ m input input-from parser id>> input-cache set-at input quot call ] + | + lrstack get next>> lrstack set + lr head>> [ +"setting seed to ans " write ans . + ans lr (>>seed) + quot parser input m lr-answer + ] [ + ans + ] if + ] ; + +:: apply-rule ( quot parser input -- result ) + [let* | + m [ input quot parser recall ] + | + m not-found = [ + quot parser input (apply-rule) + dup input input-from parser id>> input-cache set-at + ] [ + m [ + m ast>> left-recursion? [ + "Found left recursion..." print + parser m ast>> setup-lr m remaining>> m ast>> seed>> + dup input input-from parser id>> input-cache set-at + ] [ + m + dup input input-from parser id>> input-cache set-at + ] if + ] [ + f f input input-from parser id>> input-cache set-at + ] if + ] if + ] ; + :: cached-result ( input-cache input quot parser -- result ) #! Get the cached result for input position #! from the input cache. If the item is not in the cache, @@ -96,13 +220,7 @@ USE: io "<> input-cache - input quot parser cached-result ; inline - -: run-parser ( input quot -- result ) - #! If a packrat cache is available, use memoization for - #! packrat parsing, otherwise do a standard peg call. - packrat get [ run-packrat-parser ] [ call ] if* ; inline + quot parser input apply-rule ; :: parser-body ( parser -- quot ) #! Return the body of the word that is the compiled version @@ -139,7 +257,7 @@ USE: io : with-packrat ( quot -- result ) #! Run the quotation with a packrat cache active. - [ H{ } clone packrat ] dip with-variable ; inline + H{ } clone \ heads [ [ H{ } clone packrat ] dip with-variable ] with-variable ; inline : packrat-parse ( state parser -- result ) [ parse ] with-packrat ; From 4b353c75297e2ab0eb7cf23ed0c9e91caaffe90a Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 28 Mar 2008 23:20:43 +1300 Subject: [PATCH 256/886] Rewrite peg internals --- extra/peg/peg-docs.factor | 43 +---- extra/peg/peg-tests.factor | 21 +-- extra/peg/peg.factor | 323 +++++++++++-------------------------- 3 files changed, 104 insertions(+), 283 deletions(-) diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index c93d1af830..d2ca353ba1 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -12,41 +12,7 @@ HELP: parse { $description "Given the input string, parse it using the given parser. The result is a object if " "the parse was successful, otherwise it is f." } -{ $see-also compile with-packrat packrat-parse } ; - -HELP: with-packrat -{ $values - { "quot" "a quotation with stack effect ( input -- result )" } - { "result" "the result of the quotation" } -} -{ $description - "Calls the quotation with a packrat cache in scope. Usually the quotation will " - "call " { $link parse } " or call a word produced by " { $link compile } "." - "The cache is used to avoid the possible exponential time performace that pegs " - "can have, instead giving linear time at the cost of increased memory usage. " - "Use of this packrat option also allows direct and indirect recursion to " - "be handled in the parser without entering an infinite loop." } -{ $see-also compile parse packrat-parse packrat-call } ; - -HELP: packrat-parse -{ $values - { "input" "a string" } - { "parser" "a parser" } - { "result" "a parse-result or f" } -} -{ $description - "Compiles and calls the parser with a packrat cache in scope." } -{ $see-also compile parse packrat-call with-packrat } ; - -HELP: packrat-call -{ $values - { "input" "a string" } - { "quot" "a quotation with stack effect ( input -- result )" } - { "result" "a parse-result or f" } -} -{ $description - "Calls the compiled parser with a packrat cache in scope." } -{ $see-also compile packrat-call packrat-parse with-packrat } ; +{ $see-also compile } ; HELP: compile { $values @@ -54,11 +20,12 @@ HELP: compile { "word" "a word" } } { $description - "Compile the parser to a word. The word will have stack effect ( input -- result )." + "Compile the parser to a word. The word will have stack effect ( -- result )." "The mapping from parser to compiled word is kept in a cache. If you later change " "the definition of a parser you'll need to clear this cache with " - { $link reset-compiled-parsers } " before using " { $link compile } " on that parser again." } -{ $see-also compile with-packrat reset-compiled-parsers packrat-call packrat-parse } ; + { $link reset-compiled-parsers } " before using " { $link compile } " on that parser again." +} +{ $see-also parse } ; HELP: reset-compiled-parsers { $description diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index 7e2701bc48..7467a4111a 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -168,32 +168,13 @@ IN: peg.tests "1+1" swap parse parse-result-ast ] 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 - ] with-packrat - [ - "1+1" swap parse parse-result-ast - ] with-packrat -] 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 ; -[ - #! Not using packrat, so recursion causes data stack overflow - "1+1" expr parse parse-result-ast -] must-fail - { "1" } [ - #! Using packrat, so expr fails, causing the 2nd choice to be used. - "1+1" expr [ parse ] with-packrat parse-result-ast + "1+1" expr parse parse-result-ast ] unit-test { t } [ diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 96fe36f85f..81a9ed8ace 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -7,6 +7,8 @@ USING: kernel sequences strings namespaces math assocs shuffle combinators.cleave locals ; IN: peg +USE: prettyprint + TUPLE: parse-result remaining ast ; SYMBOL: ignore @@ -15,18 +17,83 @@ SYMBOL: ignore parse-result construct-boa ; SYMBOL: packrat -SYMBOL: lrstack +SYMBOL: pos +SYMBOL: input +SYMBOL: fail -TUPLE: phead rule involved-set eval-set ; -C: phead +TUPLE: memo-entry ans pos ; +C: memo-entry + +: 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 ; + +: 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 ; -: heads ( input -- h ) - input-from \ heads get at ; +: 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 ; + +: 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 [ + nip + [ ast>> ] [ remaining>> ] bi + input-from pos set + ] [ + pos set + fail + ] if* ; + +: 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 ; + +:: apply-non-memo-rule ( r p -- ast ) + [let* | + ans [ r eval-rule ] + m [ ans pos get ] + | + m p r set-memo ans + ] ; + +: apply-memo-rule ( m -- ast ) + [ ans>> ] [ pos>> ] bi pos set ; + +:: apply-rule ( r p -- ast ) + [let* | + m [ p r memo ] + | + m [ + m apply-memo-rule + ] [ + r p apply-non-memo-rule + ] if + ] ; + +: with-packrat ( input quot -- result ) + #! Run the quotation with a packrat cache active. + swap [ + input set + 0 pos set + H{ } clone packrat set + ] H{ } make-assoc swap bind ; : compiled-parsers ( -- cache ) @@ -35,203 +102,21 @@ C: phead : reset-compiled-parsers ( -- ) H{ } clone \ compiled-parsers set-global ; +reset-compiled-parsers + GENERIC: (compile) ( parser -- quot ) -: input-cache ( id -- cache ) - #! From the packrat cache, obtain the cache for the parser quotation - #! that maps the input string position to the parser result. - packrat get [ drop H{ } clone ] cache ; - -TUPLE: left-recursion seed rule head next ; -C: left-recursion - -USE: prettyprint -USE: io - - -:: handle-left-recursive-result ( result -- result ) - #! If the result is from a left-recursive call, - #! note this and fail, otherwise return normal result - #! See figure 4 of packrat_TR-2007-002.pdf. - ">>handle-left-recursive-result " write result . - result [ - [let* | ast [ result ast>> ] | - ast left-recursion? [ t ast (>>detected?) f ] [ result ] if - ] - ] [ - f - ] if - "<>(grow-lr) " write input . " for parser " write parser . " m is " write m . - [let* | - pos [ input ] - ans [ h involved-set>> clone h (>>eval-set) input quot call ] - | - [ ans not ] [ ans [ pos input-from m remaining>> input-from <= ] [ f ] if ] 2array || [ - "recursion exiting with = " write ans . "m was " write m . - m - ] [ - "recursion with = " write ans . - pos quot parser pos ans ast>> h (grow-lr) - ] if - ] - "<<(grow-lr) " write input . " for parser " write parser . " m is " write m . " result is " write dup . - ; - -:: grow-lr ( input quot parser m h -- result ) - h input input-from \ heads get set-at - input quot parser m h (grow-lr) - f input input-from \ heads get set-at ; - -SYMBOL: not-found - -: memo ( parser input -- result ) - input-from swap id>> input-cache at* [ drop not-found ] unless ; - - -:: involved? ( parser h -- ? ) - h rule>> parser = [ - t - ] [ - parser h involved-set>> member? - ] if ; - -:: recall ( input quot parser -- result ) - [let* | - m [ parser input memo ] - h [ input heads ] - | - #! If not growing a seed pass, just return what is stored - #! in the memo table. - h [ - m not-found = parser h involved? not and [ - f - ] [ - parser h eval-set>> member? [ - parser h eval-set>> remove h (>>eval-set) - input quot call - ] [ - m - ] if - ] if - ] [ - m - ] if - ] ; - -:: (setup-lr) ( parser l s -- ) - s head>> l head>> = [ - l head>> s (>>head) - l head>> [ s rule>> add ] change-involved-set drop - parser l s next>> (setup-lr) - ] unless ; - -:: setup-lr ( parser l -- ) - [let* | - s [ lrstack get ] - | - l head>> [ parser V{ } clone V{ } clone l (>>head) ] unless - parser l s (setup-lr) - ] ; - -:: lr-answer ( quot parser input m -- result ) - [let* | - h [ m ast>> head>> ] - | - h rule>> parser = [ - "changing memo ast to seed " write - m [ seed>> ast>> dup . ] change-ast drop - m input input-from parser id>> input-cache set-at - m ast>> not [ - f - ] [ - input quot parser m h grow-lr - ] if - ] [ - m ast>> seed>> - ] if - ] ; - -:: (apply-rule) ( quot parser input -- result ) - [let* | - lr [ f parser f lrstack get ] - m [ lr lrstack set input lr ] - ans [ m input input-from parser id>> input-cache set-at input quot call ] - | - lrstack get next>> lrstack set - lr head>> [ -"setting seed to ans " write ans . - ans lr (>>seed) - quot parser input m lr-answer - ] [ - ans - ] if - ] ; - -:: apply-rule ( quot parser input -- result ) - [let* | - m [ input quot parser recall ] - | - m not-found = [ - quot parser input (apply-rule) - dup input input-from parser id>> input-cache set-at - ] [ - m [ - m ast>> left-recursion? [ - "Found left recursion..." print - parser m ast>> setup-lr m remaining>> m ast>> seed>> - dup input input-from parser id>> input-cache set-at - ] [ - m - dup input input-from parser id>> input-cache set-at - ] if - ] [ - f f input input-from parser id>> input-cache set-at - ] if - ] if - ] ; - -:: cached-result ( input-cache input quot parser -- result ) - #! Get the cached result for input position - #! from the input cache. If the item is not in the cache, - #! call 'quot' with 'input' on the stack to get the result - #! and store that in the cache and return it. - #! See figure 4 of packrat_TR-2007-002.pdf. - ">>cached-result " write input . " for parser " write parser . - input input-from input-cache [ - drop - [let* | lr [ f ] - m [ input lr ] - ans [ m input input-from input-cache set-at input quot call ] - | - "--lr is " write lr . " ans is " write ans . " for parser " write parser . - ans input input-from input-cache set-at - lr detected?>> ans and [ - input quot parser ans grow-lr - ] [ - ans - ] if - ] - ] cache - dup [ handle-left-recursive-result ] when - "< ] if ] ] ; @@ -253,17 +138,8 @@ SYMBOL: not-found [ compiled-parser ] with-compilation-unit ; : parse ( state parser -- result ) - compile execute ; inline - -: with-packrat ( quot -- result ) - #! Run the quotation with a packrat cache active. - H{ } clone \ heads [ [ H{ } clone packrat ] dip with-variable ] with-variable ; inline - -: packrat-parse ( state parser -- result ) - [ parse ] with-packrat ; - -: packrat-call ( state quot -- result ) - with-packrat ; inline + dup word? [ compile ] unless + [ execute ] curry with-packrat ; parser : reset-delegates ( -- ) H{ } clone \ delegates set-global ; +reset-delegates + : init-parser ( parser -- parser ) #! Set the delegate for the parser. Equivalent parsers #! get a delegate with the same id. @@ -307,15 +185,15 @@ MATCH-VARS: ?token ; ] if ; M: token-parser (compile) ( parser -- quot ) - symbol>> [ parse-token ] curry ; - + [ \ input-slice , symbol>> , \ parse-token , ] [ ] make ; + TUPLE: satisfy-parser quot ; MATCH-VARS: ?quot ; : satisfy-pattern ( -- quot ) [ - dup empty? [ + input-slice dup empty? [ drop f ] [ unclip-slice dup ?quot call [ @@ -335,7 +213,7 @@ MATCH-VARS: ?min ?max ; : range-pattern ( -- quot ) [ - dup empty? [ + input-slice dup empty? [ drop f ] [ 0 over nth dup @@ -355,7 +233,7 @@ TUPLE: seq-parser parsers ; : seq-pattern ( -- quot ) [ dup [ - dup remaining>> ?quot [ + ?quot [ [ remaining>> swap (>>remaining) ] 2keep ast>> dup ignore = [ drop @@ -372,7 +250,7 @@ TUPLE: seq-parser parsers ; M: seq-parser (compile) ( parser -- quot ) [ - [ V{ } clone ] % + [ input-slice V{ } clone ] % parsers>> [ compiled-parser \ ?quot seq-pattern match-replace % ] each ] [ ] make ; @@ -380,24 +258,19 @@ TUPLE: choice-parser parsers ; : choice-pattern ( -- quot ) [ - dup [ - - ] [ - drop dup ?quot - ] if + [ ?quot ] unless* ] ; M: choice-parser (compile) ( parser -- quot ) - [ + [ f , parsers>> [ compiled-parser \ ?quot choice-pattern match-replace % ] each - \ nip , ] [ ] make ; TUPLE: repeat0-parser p1 ; : (repeat0) ( quot result -- result ) - 2dup remaining>> swap call [ + over call [ [ remaining>> swap (>>remaining) ] 2keep ast>> swap [ ast>> push ] keep (repeat0) @@ -412,7 +285,7 @@ TUPLE: repeat0-parser p1 ; M: repeat0-parser (compile) ( parser -- quot ) [ - [ V{ } clone ] % + [ input-slice V{ } clone ] % p1>> compiled-parser \ ?quot repeat0-pattern match-replace % ] [ ] make ; @@ -431,7 +304,7 @@ TUPLE: repeat1-parser p1 ; M: repeat1-parser (compile) ( parser -- quot ) [ - [ V{ } clone ] % + [ input-slice V{ } clone ] % p1>> compiled-parser \ ?quot repeat1-pattern match-replace % ] [ ] make ; @@ -439,7 +312,7 @@ TUPLE: optional-parser p1 ; : optional-pattern ( -- quot ) [ - dup ?quot swap f or + ?quot [ input-slice f ] unless* ] ; M: optional-parser (compile) ( parser -- quot ) @@ -449,7 +322,7 @@ TUPLE: ensure-parser p1 ; : ensure-pattern ( -- quot ) [ - dup ?quot [ + input-slice ?quot [ ignore ] [ drop f @@ -463,7 +336,7 @@ TUPLE: ensure-not-parser p1 ; : ensure-not-pattern ( -- quot ) [ - dup ?quot [ + input-slice ?quot [ drop f ] [ ignore @@ -486,7 +359,7 @@ MATCH-VARS: ?action ; ] ; M: action-parser (compile) ( parser -- quot ) - { [ p1>> ] [ quot>> ] } cleave [ compiled-parser ] dip + [ p1>> compiled-parser ] [ quot>> ] bi 2array { ?quot ?action } action-pattern match-replace ; : left-trim-slice ( string -- string ) @@ -500,7 +373,7 @@ TUPLE: sp-parser p1 ; M: sp-parser (compile) ( parser -- quot ) [ - \ left-trim-slice , p1>> compiled-parser , + \ input-slice , \ left-trim-slice , \ input-from , \ pos , \ set , p1>> compiled-parser , ] [ ] make ; TUPLE: delay-parser quot ; From cca4700e490f26ef8394df099582313537cf575c Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 29 Mar 2008 00:41:41 +1300 Subject: [PATCH 257/886] Fix ebnf for peg changes --- extra/peg/ebnf/ebnf-tests.factor | 16 +--------------- extra/peg/ebnf/ebnf.factor | 6 +++--- 2 files changed, 4 insertions(+), 18 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index dea549eb37..a511e271c2 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -147,27 +147,13 @@ IN: peg.ebnf.tests [ #! Test direct left recursion. Currently left recursion should cause a #! failure of that parser. - #! Not using packrat, so recursion causes data stack overflow "1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call ] must-fail -{ V{ 49 } } [ - #! Test direct left recursion. Currently left recursion should cause a - #! failure of that parser. - #! 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 ] with-packrat parse-result-ast -] unit-test - [ #! Test indirect left recursion. Currently left recursion should cause a #! failure of that parser. - #! Not using packrat, so recursion causes data stack overflow + #! Using packrat, so first part of expr fails, causing 2nd choice to be used "1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call ] must-fail -{ V{ 49 } } [ - #! Test indirect left recursion. Currently left recursion should cause a - #! failure of that parser. - #! Using packrat, so first part of expr fails, causing 2nd choice to be used - "1+1" [ [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call ] with-packrat parse-result-ast -] unit-test diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index ed0dea0410..3efe2d6979 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -266,7 +266,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) ] [ ] make delay sp ; : transform-ebnf ( string -- object ) - 'ebnf' packrat-parse parse-result-ast transform ; + 'ebnf' parse parse-result-ast transform ; : check-parse-result ( result -- result ) dup [ @@ -281,8 +281,8 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) ] if ; : ebnf>quot ( string -- hashtable quot ) - 'ebnf' packrat-parse check-parse-result - parse-result-ast transform dup main swap at compile 1quotation ; + 'ebnf' parse check-parse-result + parse-result-ast transform dup main swap at compile [ parse ] curry ; : [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing From 010ce8007607a2867c6bb2586b7cfb4890fc81c0 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 29 Mar 2008 00:49:39 +1300 Subject: [PATCH 258/886] Handle left recursion by failing again --- extra/peg/ebnf/ebnf-tests.factor | 13 +++++++------ extra/peg/peg.factor | 6 ++++-- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index a511e271c2..aa47d37e55 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -144,16 +144,17 @@ IN: peg.ebnf.tests "Z" [EBNF foo=[^A-Z] EBNF] call ] unit-test -[ +{ V{ 49 } } [ #! Test direct left recursion. Currently left recursion should cause a #! failure of that parser. - "1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call -] must-fail + #! 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{ 49 } } [ #! Test indirect left recursion. Currently left recursion should cause a #! failure of that parser. #! Using packrat, so first part of expr fails, causing 2nd choice to be used - "1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call -] must-fail + "1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call parse-result-ast +] unit-test diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 81a9ed8ace..1d2f67f52e 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -67,10 +67,12 @@ C: memo-entry :: apply-non-memo-rule ( r p -- ast ) [let* | + m [ fail p dup p r set-memo ] ans [ r eval-rule ] - m [ ans pos get ] | - m p r set-memo ans + ans m (>>ans) + pos get m (>>pos) + ans ] ; : apply-memo-rule ( m -- ast ) From 68cbdf76aa05aa684ecbe966aba04e4ca3797fe4 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 29 Mar 2008 01:17:54 +1300 Subject: [PATCH 259/886] Handle direct left recusion --- extra/peg/peg.factor | 39 +++++++++++++++++++++++++++++++++++---- 1 file changed, 35 insertions(+), 4 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 1d2f67f52e..b24ee0aa62 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -24,6 +24,9 @@ SYMBOL: fail TUPLE: memo-entry ans pos ; C: memo-entry +TUPLE: left-recursion detected? ; +C: left-recursion + : rule-parser ( rule -- parser ) #! A rule is the parser compiled down to a word. It has #! a "peg" property containing the original parser. @@ -48,7 +51,9 @@ C: memo-entry #! Return fail if the rule failed. The rule has #! stack effect ( input -- parse-result ) pos get swap - execute [ + execute +! drop f f + [ nip [ ast>> ] [ remaining>> ] bi input-from pos set @@ -65,18 +70,44 @@ C: memo-entry #! Store an entry in the cache rule-parser input-cache set-at ; +:: (grow-lr) ( r p m h -- ) + p pos set + r eval-rule + dup fail = pos get m pos>> <= or [ + drop + ] [ + m (>>ans) + pos get m (>>pos) + r p m h (grow-lr) + ] if ; + +:: grow-lr ( r p m h -- ast ) + #! Placeholder for full left recursion implementation + r p m h (grow-lr) m pos>> pos set m ans>> + ; + :: apply-non-memo-rule ( r p -- ast ) [let* | - m [ fail p dup p r set-memo ] + lr [ f ] + m [ lr p dup p r set-memo ] ans [ r eval-rule ] | ans m (>>ans) pos get m (>>pos) - ans + lr detected?>> ans fail = not and [ + r p m f grow-lr + ] [ + ans + ] if ] ; : apply-memo-rule ( m -- ast ) - [ ans>> ] [ pos>> ] bi pos set ; + [ ans>> ] [ pos>> ] bi + pos set + dup left-recursion? [ + t swap (>>detected?) + fail + ] when ; :: apply-rule ( r p -- ast ) [let* | From dd979c8b3b42b5da7ed5832bff4b9a2882d3c2ee Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 29 Mar 2008 02:45:21 +1300 Subject: [PATCH 260/886] Indirect Left recursive grammars working --- extra/peg/peg.factor | 102 +++++++++++++++++++++++++++++++++++-------- 1 file changed, 84 insertions(+), 18 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index b24ee0aa62..fd00c3d2ae 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -20,13 +20,18 @@ SYMBOL: packrat SYMBOL: pos SYMBOL: input SYMBOL: fail +SYMBOL: lrstack +SYMBOL: heads TUPLE: memo-entry ans pos ; C: memo-entry -TUPLE: left-recursion detected? ; +TUPLE: left-recursion seed rule head next ; C: left-recursion +TUPLE: peg-head rule involved-set eval-set ; +C: 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. @@ -72,6 +77,7 @@ C: left-recursion :: (grow-lr) ( r p m h -- ) p pos set + h involved-set>> clone h (>>eval-set) r eval-rule dup fail = pos get m pos>> <= or [ drop @@ -82,39 +88,97 @@ C: left-recursion ] if ; :: grow-lr ( r p m h -- ast ) - #! Placeholder for full left recursion implementation - r p m h (grow-lr) m pos>> pos set m ans>> + h p heads get set-at + r p m h (grow-lr) + p heads get delete-at + m pos>> pos set m ans>> ; +:: (setup-lr) ( r l s -- ) + s head>> l head>> eq? [ + l head>> s (>>head) + l head>> [ s rule>> add ] change-involved-set drop + r l s next>> (setup-lr) + ] unless ; + +:: setup-lr ( r l -- ) + l head>> [ + r V{ } clone V{ } clone 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>> fail = [ + fail + ] [ + r p m h grow-lr + ] if + ] [ + m ans>> seed>> + ] if + ] ; + +:: recall ( r p -- memo-entry ) + [let* | + m [ p r memo ] + h [ p heads get at ] + | + h [ + m r h involved-set>> h rule>> add member? not and [ + fail p + ] [ + r h eval-set>> member? [ + h [ r swap remove ] change-eval-set drop + r eval-rule + m (>>ans) + pos get m (>>pos) + m + ] [ + m + ] if + ] if + ] [ + m + ] if + ] ; + :: apply-non-memo-rule ( r p -- ast ) [let* | - lr [ f ] - m [ lr p dup p r set-memo ] + lr [ fail r f lrstack get ] + m [ lr lrstack set lr p dup p r set-memo ] ans [ r eval-rule ] | - ans m (>>ans) + lrstack get next>> lrstack set pos get m (>>pos) - lr detected?>> ans fail = not and [ - r p m f grow-lr + lr head>> [ + ans lr (>>seed) + r p m lr-answer ] [ + ans m (>>ans) ans - ] if + ] if ] ; -: apply-memo-rule ( m -- ast ) - [ ans>> ] [ pos>> ] bi - pos set - dup left-recursion? [ - t swap (>>detected?) - fail - ] when ; +:: apply-memo-rule ( r m -- ast ) + m pos>> pos set + m ans>> left-recursion? [ + r m ans>> setup-lr + m ans>> seed>> + ] [ + m ans>> + ] if ; :: apply-rule ( r p -- ast ) [let* | - m [ p r memo ] + m [ r p recall ] | m [ - m apply-memo-rule + r m apply-memo-rule ] [ r p apply-non-memo-rule ] if @@ -125,6 +189,8 @@ C: left-recursion swap [ input set 0 pos set + f lrstack set + H{ } clone heads set H{ } clone packrat set ] H{ } make-assoc swap bind ; From 261539a86ab13a9cc5c3be69cc8de2e317f8d6d9 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 29 Mar 2008 02:47:03 +1300 Subject: [PATCH 261/886] Unit test for left recursive grammar --- extra/peg/peg-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index 7467a4111a..f57fe83220 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -173,8 +173,8 @@ IN: peg.tests #! failure of that parser. [ expr ] delay "+" token "1" token 3seq "1" token 2choice ; -{ "1" } [ - "1+1" expr parse parse-result-ast +{ V{ V{ "1" "+" "1" } "+" "1" } } [ + "1+1+1" expr parse parse-result-ast ] unit-test { t } [ From 25eea7ea1b6d115e749dd9650b8975b3a86495e6 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 29 Mar 2008 02:51:49 +1300 Subject: [PATCH 262/886] Fix ebnf tests for left recursion --- extra/peg/ebnf/ebnf-tests.factor | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index aa47d37e55..fbf13f69a2 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -144,17 +144,21 @@ IN: peg.ebnf.tests "Z" [EBNF foo=[^A-Z] EBNF] call ] unit-test -{ V{ 49 } } [ - #! Test direct left recursion. Currently left recursion should cause a - #! failure of that parser. +{ 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{ 49 } } [ - #! Test indirect left recursion. Currently left recursion should cause a - #! failure of that parser. +{ 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" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call parse-result-ast + "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 From 7bf27a5eb2034ad704ecadd131da0e8c655f69fb Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 29 Mar 2008 03:41:40 +1300 Subject: [PATCH 263/886] EBNF test using Java Primary production --- extra/peg/ebnf/ebnf-tests.factor | 44 ++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index fbf13f69a2..c2c0a50a59 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -162,3 +162,47 @@ IN: peg.ebnf.tests "1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call parse-result-ast ] 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 From 3e2a867c3a743d8d1b8cd03c8ca5f33115ef17ef Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 28 Mar 2008 13:37:05 -0500 Subject: [PATCH 264/886] implement touch-file on windows --- extra/io/windows/files/files.factor | 41 ++++++++++++++++++++++++++++- extra/io/windows/windows.factor | 21 ++++++++++++++- 2 files changed, 60 insertions(+), 2 deletions(-) diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index 655b5f9daf..7d88392fdc 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -3,7 +3,8 @@ USING: alien.c-types io.backend io.files io.windows kernel math windows windows.kernel32 combinators.cleave windows.time calendar combinators math.functions -sequences namespaces words symbols ; +sequences namespaces words symbols combinators.lib +io.nonblocking destructors ; IN: io.windows.files SYMBOLS: +read-only+ +hidden+ +system+ @@ -93,3 +94,41 @@ M: windows-nt-io file-info ( path -- info ) M: windows-nt-io link-info ( path -- info ) file-info ; + +: file-times ( path -- timestamp timestamp timestamp ) + [ + normalize-pathname open-existing dup close-always + "FILETIME" + "FILETIME" + "FILETIME" + [ 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-pathname 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: windows-nt-io touch-file ( path -- ) + [ + normalize-pathname + maybe-create-file over close-always + [ drop ] [ f now dup (set-file-times) ] if + ] with-destructors ; diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 635a992777..64c4684e15 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -58,7 +58,8 @@ M: win32-file close-handle ( handle -- ) ] 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 ; @@ -69,6 +70,24 @@ M: win32-file close-handle ( handle -- ) : (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 FILE_BEGIN SetFilePointer INVALID_SET_FILE_POINTER = [ From 8cf2fd88a52820650b62cdafeb35575e92127f8a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 28 Mar 2008 13:50:23 -0500 Subject: [PATCH 265/886] allow random-32* or random-bytes* to generate randomness in terms of each other --- .../mersenne-twister/mersenne-twister-tests.factor | 4 ++-- extra/random/mersenne-twister/mersenne-twister.factor | 2 +- extra/random/random.factor | 9 ++++++--- extra/random/windows/cryptographic/cryptographic.factor | 1 - 4 files changed, 9 insertions(+), 7 deletions(-) diff --git a/extra/random/mersenne-twister/mersenne-twister-tests.factor b/extra/random/mersenne-twister/mersenne-twister-tests.factor index 49bf4ad3f3..703a0c16e4 100755 --- a/extra/random/mersenne-twister/mersenne-twister-tests.factor +++ b/extra/random/mersenne-twister/mersenne-twister-tests.factor @@ -16,11 +16,11 @@ IN: random.mersenne-twister.tests [ 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 + 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 + 0 [ 10000 [ drop random-generator get random-32* drop ] each random-generator get random-32* ] test-rng ] unit-test diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index ed515716e0..53ec91b118 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -67,7 +67,7 @@ PRIVATE> M: mersenne-twister seed-random ( mt seed -- ) init-mt-seq >>seq drop ; -M: mersenne-twister random-32 ( mt -- r ) +M: mersenne-twister random-32* ( mt -- r ) dup [ seq>> ] [ i>> ] bi dup mt-n < [ drop 0 pick mt-generate ] unless new-nth mt-temper diff --git a/extra/random/random.factor b/extra/random/random.factor index b10e05d415..f4d4022ae9 100755 --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types kernel math namespaces sequences -io.backend ; +io.backend io.binary ; IN: random SYMBOL: random-generator @@ -12,11 +12,14 @@ HOOK: os-crypto-random-32 io-backend ( -- r ) HOOK: os-random-32 io-backend ( -- r ) GENERIC: seed-random ( tuple seed -- ) -GENERIC: random-32 ( tuple -- r ) +GENERIC: random-32* ( tuple -- r ) GENERIC: random-bytes* ( tuple n -- bytes ) M: object random-bytes* ( tuple n -- byte-array ) - [ drop random-32 ] with map >c-uint-array ; + [ drop random-32* ] with map >c-uint-array ; + +M: object random-32* ( tuple -- n ) + 4 random-bytes* le> ; : random-bytes ( n -- r ) [ diff --git a/extra/random/windows/cryptographic/cryptographic.factor b/extra/random/windows/cryptographic/cryptographic.factor index 158f939af9..3f64209200 100644 --- a/extra/random/windows/cryptographic/cryptographic.factor +++ b/extra/random/windows/cryptographic/cryptographic.factor @@ -26,4 +26,3 @@ M: windows-cryptographic-rng random-bytes* ( tuple n -- bytes ) dup f f PROV_RSA_AES CRYPT_NEWKEYSET CryptAcquireContextW win32-error=0/f *void* ; - From 482efc9c58e6c0e348faf5ec6033fbf22f6169fd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 28 Mar 2008 15:09:21 -0500 Subject: [PATCH 266/886] fix load errors --- extra/random/blum-blum-shub/blum-blum-shub.factor | 2 +- extra/random/dummy/dummy.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor index 2e59b625b1..00bf22d2a9 100755 --- a/extra/random/blum-blum-shub/blum-blum-shub.factor +++ b/extra/random/blum-blum-shub/blum-blum-shub.factor @@ -32,5 +32,5 @@ IN: crypto ! ! #! Cryptographically secure random number using Blum-Blum-Shub 256 ! [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ; -M: blum-blum-shub random-32 ( bbs -- r ) +M: blum-blum-shub random-32* ( bbs -- r ) ; diff --git a/extra/random/dummy/dummy.factor b/extra/random/dummy/dummy.factor index 12607456ec..9120381955 100755 --- a/extra/random/dummy/dummy.factor +++ b/extra/random/dummy/dummy.factor @@ -7,5 +7,5 @@ C: random-dummy M: random-dummy seed-random ( seed obj -- ) (>>i) ; -M: random-dummy random-32 ( obj -- r ) +M: random-dummy random-32* ( obj -- r ) [ dup 1+ ] change-i drop ; From a0975b5c463b7575adde3b1f43fcfa1e91bb59f2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Mar 2008 20:28:17 -0500 Subject: [PATCH 267/886] Adding some unit tests --- core/tuples/tuples-tests.factor | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index e670c26c25..09795888a8 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -316,6 +316,30 @@ C: server "IN: tuples.tests TUPLE: bad-superclass < word ;" eval ] must-fail +! Reshaping with inheritance +TUPLE: electronic-device ; + +[ ] [ "IN: tuples.tests TUPLE: computer < electronic-device ;" 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: tuples.tests TUPLE: computer ;" eval ] unit-test + +[ f ] [ "laptop" get electronic-device? ] unit-test +[ t ] [ "laptop" get computer? ] unit-test + ! Hardcore unit tests USE: threads From 965c03cec5f793c7539abd1d2710498e1c5bd8ff Mon Sep 17 00:00:00 2001 From: erg Date: Fri, 28 Mar 2008 21:15:41 -0500 Subject: [PATCH 268/886] fix teh bugz --- build-support/target | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-support/target b/build-support/target index 1fbfb31d11..ffb677b681 100755 --- a/build-support/target +++ b/build-support/target @@ -1,4 +1,4 @@ -#!/bin/sh +#!/usr/bin/env bash uname_s=`uname -s` case $uname_s in From 5f37b4fc72d87336574810cce0e458ddda5ea8c6 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 29 Mar 2008 16:11:08 +1300 Subject: [PATCH 269/886] compiled pegs infer --- extra/peg/peg.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index fd00c3d2ae..8f7522bda9 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -65,7 +65,7 @@ C: peg-head ] [ pos set fail - ] if* ; + ] if* ; inline : memo ( pos rule -- memo-entry ) #! Return the result from the memo cache. @@ -85,14 +85,14 @@ C: peg-head m (>>ans) pos get m (>>pos) r p m h (grow-lr) - ] if ; + ] if ; inline :: grow-lr ( r p m h -- ast ) h p heads get set-at r p m h (grow-lr) p heads get delete-at m pos>> pos set m ans>> - ; + ; inline :: (setup-lr) ( r l s -- ) s head>> l head>> eq? [ @@ -121,7 +121,7 @@ C: peg-head ] [ m ans>> seed>> ] if - ] ; + ] ; inline :: recall ( r p -- memo-entry ) [let* | @@ -145,7 +145,7 @@ C: peg-head ] [ m ] if - ] ; + ] ; inline :: apply-non-memo-rule ( r p -- ast ) [let* | @@ -162,7 +162,7 @@ C: peg-head ans m (>>ans) ans ] if - ] ; + ] ; inline :: apply-memo-rule ( r m -- ast ) m pos>> pos set @@ -182,7 +182,7 @@ C: peg-head ] [ r p apply-non-memo-rule ] if - ] ; + ] ; inline : with-packrat ( input quot -- result ) #! Run the quotation with a packrat cache active. From 0db0d9cd444eaa920088f172844b4fdbc0f690b7 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 29 Mar 2008 16:24:13 +1300 Subject: [PATCH 270/886] Move towards having ebnf infer --- extra/peg/ebnf/ebnf.factor | 2 +- extra/peg/peg.factor | 8 +++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 3efe2d6979..76e851efd3 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -282,7 +282,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) : ebnf>quot ( string -- hashtable quot ) 'ebnf' parse check-parse-result - parse-result-ast transform dup main swap at compile [ parse ] curry ; + parse-result-ast transform dup main swap at compile [ compiled-parse ] curry ; : [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 8f7522bda9..be4bba25fc 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -192,7 +192,7 @@ C: peg-head f lrstack set H{ } clone heads set H{ } clone packrat set - ] H{ } make-assoc swap bind ; + ] H{ } make-assoc swap bind ; inline : compiled-parsers ( -- cache ) @@ -236,9 +236,11 @@ GENERIC: (compile) ( parser -- quot ) : compile ( parser -- word ) [ compiled-parser ] with-compilation-unit ; +: compiled-parse ( state word -- result ) + swap [ execute ] with-packrat ; inline + : parse ( state parser -- result ) - dup word? [ compile ] unless - [ execute ] curry with-packrat ; + dup word? [ compile ] unless compiled-parse ; Date: Fri, 28 Mar 2008 22:46:14 -0500 Subject: [PATCH 271/886] fix makefile --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 7bced81e47..5f7cdca06d 100755 --- a/Makefile +++ b/Makefile @@ -46,7 +46,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ EXE_OBJS = $(PLAF_EXE_OBJS) default: - $(MAKE) `./misc/factor.sh make-target` + $(MAKE) `./build-support/factor.sh make-target` help: @echo "Run '$(MAKE)' with one of the following parameters:" From d8abb49a9b68f8b3b8fe3f72da9bfd3a107e0a3e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Mar 2008 22:59:48 -0500 Subject: [PATCH 272/886] Working on classes --- core/bootstrap/primitives.factor | 8 ++-- core/classes/classes.factor | 15 ++++--- core/classes/predicate/predicate.factor | 4 +- core/classes/union/union.factor | 2 +- core/tuples/tuples.factor | 60 ++++++++++++++----------- 5 files changed, 50 insertions(+), 39 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index baa85032bc..50dea27e7b 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -341,7 +341,7 @@ define-tuple-slots ! 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 +f "f" "syntax" lookup builtins get remove [ ] subset union-class define-class "f" "syntax" create [ not ] "predicate" set-word-prop @@ -353,15 +353,15 @@ define-class ! 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 +f builtins get [ ] subset union-class define-class ! Class of objects with object tag "hi-tag" "classes.private" create -builtins get num-tags get tail f union-class define-class +f builtins get num-tags get tail union-class define-class ! Null class with no instances. "null" "kernel" create [ drop f ] "predicate" set-word-prop -"null" "kernel" create { } f union-class define-class +"null" "kernel" create f { } union-class define-class ! Create special tombstone values "tombstone" "hashtables.private" create diff --git a/core/classes/classes.factor b/core/classes/classes.factor index c21dd452ac..ccb735f392 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -83,13 +83,12 @@ M: word reset-class drop ; : update-map- ( class -- ) dup class-uses update-map get remove-vertex ; -PRIVATE> - -: define-class-props ( members superclass metaclass -- assoc ) +: define-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 -- ) @@ -100,6 +99,8 @@ PRIVATE> over "predicating" set-word-prop t "class" set-word-prop ; +PRIVATE> + GENERIC: update-predicate ( class -- ) M: class update-predicate drop ; @@ -109,7 +110,7 @@ M: class update-predicate drop ; GENERIC: update-methods ( assoc -- ) -: define-class ( word members superclass metaclass -- ) +: define-class ( word superclass members metaclass -- ) #! If it was already a class, update methods after. reset-caches define-class-props diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index 9f5961895a..b2a5a03bb4 100755 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -14,8 +14,8 @@ PREDICATE: predicate-class < class ] [ ] make ; : define-predicate-class ( class superclass definition -- ) - >r >r dup f r> predicate-class define-class r> - dupd "predicate-definition" set-word-prop + >r dupd f predicate-class define-class + r> dupd "predicate-definition" set-word-prop dup predicate-quot define-predicate ; M: predicate-class reset-class diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 3a791c22d0..814ab0e838 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -36,7 +36,7 @@ PREDICATE: union-class < class M: union-class update-predicate define-union-predicate ; : define-union-class ( class members -- ) - dupd f union-class define-class define-union-predicate ; + >r dup f r> union-class define-class define-union-predicate ; M: union-class reset-class { "metaclass" "members" } reset-props ; diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 89aff6f185..60606357d3 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -124,7 +124,8 @@ PRIVATE> [ [ swap ?nth ] [ drop f ] if* ] with map append >tuple ; -: reshape-tuples ( class newslots -- ) +: reshape-tuples ( class superclass newslots -- ) + nip >r dup "slot-names" word-prop r> permutation [ >r [ swap class eq? ] curry instances dup r> @@ -132,36 +133,45 @@ PRIVATE> become ] 2curry after-compilation ; -: tuple-class-unchanged ( class superclass slots -- ) 3drop ; - -: prepare-tuple-class ( class slots -- ) - dupd define-tuple-slots - dup define-tuple-layout - define-tuple-predicate ; - -: change-superclass "not supported" throw ; +: define-new-tuple-class ( class superclass slots -- ) + [ drop f tuple-class define-class ] + [ nip define-tuple-slots ] + [ + 2drop + [ define-tuple-layout ] + [ define-tuple-predicate ] + bi + ] + 3tri ; : redefine-tuple-class ( class superclass slots -- ) - >r 2dup swap superclass eq? - [ drop ] [ dupd change-superclass ] if r> - 2dup forget-slots - 2dup reshape-tuples - over changed-word - over redefined - prepare-tuple-class ; + [ reshape-tuples ] + [ + drop + [ forget-slots ] + [ drop changed-word ] + [ drop redefined ] + 2tri + ] + [ define-new-tuple-class ] + 3tri ; -: define-new-tuple-class ( class superclass slots -- ) - >r dupd f swap tuple-class define-class r> - prepare-tuple-class ; +: tuple-class-unchanged? ( class superclass slots -- ? ) + rot tuck + [ "superclass" word-prop = ] + [ "slot-names" word-prop = ] 2bi* and ; PRIVATE> -: define-tuple-class ( class superclass slots -- ) - { - { [ pick tuple-class? not ] [ define-new-tuple-class ] } - { [ pick "slot-names" word-prop over = ] [ tuple-class-unchanged ] } - { [ t ] [ redefine-tuple-class ] } - } cond ; +GENERIC# define-tuple-class 2 ( class superclass slots -- ) + +M: word define-tuple-class + define-new-tuple-class ; + +M: tuple-class define-tuple-class + 3dup tuple-class-unchanged? + [ 3dup redefine-tuple-class ] unless + 3drop ; : define-error-class ( class superclass slots -- ) pick >r define-tuple-class r> From 1f3e6fd0b72bc89667a7634faad4b573c34403d3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Mar 2008 23:00:20 -0500 Subject: [PATCH 273/886] combinators.cleave is now core --- core/kernel/kernel.factor | 77 +++++++++++++++---- extra/benchmark/benchmark.factor | 2 +- extra/boids/boids.factor | 1 - extra/boids/ui/ui.factor | 1 - extra/bunny/bunny.factor | 15 ++-- extra/bunny/model/model.factor | 10 +-- extra/bunny/outlined/outlined.factor | 7 +- extra/cairo/lib/lib.factor | 3 +- extra/cairo/png/png.factor | 5 +- extra/calendar/format/format.factor | 3 +- extra/calendar/windows/windows.factor | 3 +- extra/cfdg/cfdg.factor | 2 +- extra/colors/hsv/hsv.factor | 3 +- extra/combinators/lib/lib.factor | 3 +- .../distributed/distributed.factor | 5 +- extra/db/postgresql/lib/lib.factor | 8 +- extra/db/postgresql/postgresql.factor | 2 +- extra/db/sqlite/sqlite.factor | 2 +- extra/db/tuples/tuples.factor | 3 +- extra/http/http.factor | 3 +- extra/http/server/actions/actions.factor | 2 +- extra/http/server/auth/login/login.factor | 4 +- extra/http/server/callbacks/callbacks.factor | 3 +- .../http/server/components/components.factor | 2 +- extra/http/server/db/db.factor | 2 +- extra/http/server/server.factor | 2 +- extra/http/server/sessions/sessions.factor | 4 +- .../sessions/storage/assoc/assoc.factor | 5 +- .../http/server/sessions/storage/db/db.factor | 2 +- extra/http/server/static/static.factor | 3 +- .../http/server/validators/validators.factor | 3 +- extra/io/encodings/8-bit/8-bit.factor | 7 +- extra/io/unix/files/files.factor | 4 +- extra/io/windows/files/files.factor | 9 +-- extra/io/windows/nt/files/files.factor | 3 +- extra/locals/locals.factor | 2 +- extra/lsys/strings/interpret/interpret.factor | 2 +- extra/lsys/strings/rewrite/rewrite.factor | 2 +- extra/lsys/strings/strings.factor | 2 +- extra/math/analysis/analysis.factor | 2 +- extra/math/matrices/matrices.factor | 2 +- extra/opengl/demo-support/demo-support.factor | 2 +- extra/opengl/shaders/shaders.factor | 2 +- extra/project-euler/039/039.factor | 2 +- extra/project-euler/075/075.factor | 2 +- extra/random-weighted/random-weighted.factor | 2 +- .../blum-blum-shub/blum-blum-shub.factor | 2 +- .../mersenne-twister/mersenne-twister.factor | 3 +- extra/raptor/cron/cron.factor | 2 +- extra/raptor/cronjobs.factor | 2 +- extra/raptor/raptor.factor | 3 +- extra/reports/noise/noise.factor | 4 +- extra/reports/optimizer/optimizer.factor | 2 +- extra/serialize/serialize.factor | 4 +- extra/springies/springies.factor | 2 +- extra/springies/ui/ui.factor | 2 +- extra/tools/walker/walker.factor | 2 +- extra/ui/tools/walker/walker.factor | 2 +- extra/unix/process/process.factor | 2 +- extra/windows/com/syntax/syntax.factor | 8 +- .../code2html/responder/responder.factor | 2 +- 61 files changed, 151 insertions(+), 126 deletions(-) diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 2d99f0793b..1987597c58 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel.private ; IN: kernel @@ -27,24 +27,28 @@ DEFER: if : 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 @@ -53,6 +57,7 @@ DEFER: if : dip ( obj quot -- obj ) swap slip ; inline +! Keepers : keep ( x quot -- x ) over slip ; inline : 2keep ( x y quot -- x y ) 2over 2slip ; inline @@ -60,7 +65,48 @@ DEFER: if : 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 -- 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 + +! Double cleavers +: 2bi ( x y p q -- p[x,y] q[x,y] ) + >r 2keep r> call ; inline + +: 2tri ( x y p q r -- p[x,y] q[x,y] r[x,y] ) + >r >r 2keep r> 2keep r> call ; inline + +! Triple cleavers +: 3bi ( x y z p q -- p[x,y,z] q[x,y,z] ) + >r 3keep r> call ; inline + +: 3tri ( x y z p q r -- p[x,y,z] q[x,y,z] r[x,y,z] ) + >r >r 3keep r> 3keep r> call ; inline + +! Spreaders +: 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 + +! Double spreaders +: 2bi* ( w x y z p q -- p[w,x] q[y,z] ) + >r -rot 2slip r> call ; inline + +! Appliers +: bi@ ( x y p -- p[x] p[y] ) + tuck 2slip call ; inline + +: tri@ ( x y z p -- p[x] p[y] p[z] ) + tuck >r bi@ r> call ; inline + +! Double appliers +: 2bi@ ( w x y z p -- p[w,x] p[y,z] ) + dup -roll 3slip call ; inline : while ( pred body tail -- ) >r >r dup slip r> r> roll @@ -135,11 +181,11 @@ USE: tuples.private : 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 @@ -155,3 +201,6 @@ USE: tuples.private : do-primitive ( number -- ) "Improper primitive call" throw ; PRIVATE> + +! Deprecated +: 2apply bi@ ; inline diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index 26f1a9e96d..a75251331f 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -2,7 +2,7 @@ ! 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 ) diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index 611e00a9b4..efa7216699 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -6,7 +6,6 @@ USING: kernel namespaces math.vectors math.trig combinators arrays sequences random vars - combinators.cleave combinators.lib ; IN: boids diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index b545f41060..a1feac381d 100755 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -19,7 +19,6 @@ USING: kernel namespaces ui.gadgets.packs ui.gadgets.grids ui.gestures - combinators.cleave assocs.lib vars rewrite-closures boids ; IN: boids.ui diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index 963379896d..43b9edcd00 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -1,11 +1,10 @@ -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 ; diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 1d90209ed4..79a8a00856 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -1,8 +1,8 @@ -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 ) diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 6295e3b9de..7cdfba7c79 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -1,7 +1,6 @@ -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 ; IN: bunny.outlined STRING: outlined-pass1-fragment-shader-main-source diff --git a/extra/cairo/lib/lib.factor b/extra/cairo/lib/lib.factor index 1b969978a3..4f532cd9ec 100755 --- a/extra/cairo/lib/lib.factor +++ b/extra/cairo/lib/lib.factor @@ -1,8 +1,7 @@ ! 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 -accessors ; +kernel libc locals math shuffle accessors ; IN: cairo.lib TUPLE: cairo-t alien ; diff --git a/extra/cairo/png/png.factor b/extra/cairo/png/png.factor index 55828cde9c..eaab28e659 100755 --- a/extra/cairo/png/png.factor +++ b/extra/cairo/png/png.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators.cleave kernel -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 ; IN: cairo.png TUPLE: png surface width height cairo-t array ; diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index 0ac0ebb2c3..b0bd7c464f 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -1,6 +1,5 @@ USING: math math.parser kernel sequences io calendar -accessors arrays io.streams.string combinators accessors -combinators.cleave ; +accessors arrays io.streams.string combinators accessors ; IN: calendar.format GENERIC: day. ( obj -- ) diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor index 6986902ff1..8548e4ee52 100755 --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -1,6 +1,5 @@ USING: calendar.backend namespaces alien.c-types -windows windows.kernel32 kernel math combinators.cleave -combinators ; +windows windows.kernel32 kernel math combinators ; IN: calendar.windows TUPLE: windows-calendar ; diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index c3ada95533..8a1d93aceb 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -3,7 +3,7 @@ USING: kernel alien.c-types combinators namespaces arrays 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 diff --git a/extra/colors/hsv/hsv.factor b/extra/colors/hsv/hsv.factor index 8d91d971e4..dd2811822b 100644 --- a/extra/colors/hsv/hsv.factor +++ b/extra/colors/hsv/hsv.factor @@ -1,8 +1,7 @@ ! 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 diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 9fe19555c5..deb03f72e2 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -4,8 +4,7 @@ ! See http://factorcode.org/license.txt for BSD license. 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 diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index c007e9f152..6704272305 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -1,8 +1,7 @@ ! 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 +USING: serialize sequences concurrency.messaging threads io +io.server qualified arrays namespaces kernel io.encodings.binary accessors ; QUALIFIED: io.sockets IN: concurrency.distributed diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index 270be886c5..bfe7dab3ce 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -2,10 +2,10 @@ ! 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 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.streams.byte-array ; IN: db.postgresql.lib : postgresql-result-error-message ( res -- str/f ) diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 8a6f8632ec..f9805560ad 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -5,7 +5,7 @@ kernel math math.parser namespaces prettyprint quotations 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 ; IN: db.postgresql TUPLE: postgresql-db host port pgopts pgtty db user pass ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index d7d954c0dc..c81448865f 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -5,7 +5,7 @@ hashtables io.files kernel math math.parser namespaces prettyprint sequences strings tuples alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators -combinators.cleave io namespaces.lib ; +io namespaces.lib ; USE: tools.walker IN: db.sqlite diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 0f69b0fafb..00e8ed8b76 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -3,8 +3,7 @@ USING: arrays assocs classes db kernel namespaces tuples words sequences slots math 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 -- ) diff --git a/extra/http/http.factor b/extra/http/http.factor index 0bb983c53d..69c0ba2c9f 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -4,8 +4,7 @@ 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 accessors calendar -calendar.format quotations arrays combinators.cleave -combinators.lib byte-arrays ; +calendar.format quotations arrays combinators.lib byte-arrays ; IN: http : http-port 80 ; inline diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index f39980037d..fcafa57ff6 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors sequences kernel assocs combinators http.server http.server.validators http hashtables namespaces -combinators.cleave fry continuations locals ; +fry continuations locals ; IN: http.server.actions SYMBOL: +append-path diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 8c61a9dd47..89984b0e84 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -6,8 +6,8 @@ http.server.auth.providers http.server.auth.providers.null http.server.actions http.server.components http.server.sessions http.server.templating.fhtml http.server.validators http.server.auth http sequences io.files namespaces hashtables -fry io.sockets combinators.cleave arrays threads locals -qualified continuations destructors ; +fry io.sockets arrays threads locals qualified continuations +destructors ; IN: http.server.auth.login QUALIFIED: smtp diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor index ab629ae236..e1b737a9c6 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/http/server/callbacks/callbacks.factor @@ -3,8 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: html http http.server io kernel math namespaces continuations calendar sequences assocs hashtables -accessors arrays alarms quotations combinators -combinators.cleave fry assocs.lib ; +accessors arrays alarms quotations combinators fry assocs.lib ; IN: http.server.callbacks SYMBOL: responder diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 516abe79a5..828ff8e562 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -4,7 +4,7 @@ USING: 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 ; +fry continuations math ; IN: http.server.components SYMBOL: components diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor index 0b2e9bccc3..a0d732c1ef 100755 --- a/extra/http/server/db/db.factor +++ b/extra/http/server/db/db.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: db http.server kernel accessors -continuations namespaces destructors combinators.cleave ; +continuations namespaces destructors ; IN: http.server.db TUPLE: db-persistence responder db params ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 81201dd3fe..2cc0f80f03 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -4,7 +4,7 @@ USING: assocs kernel namespaces io io.timeouts strings splitting threads http sequences prettyprint io.server logging calendar html.elements accessors math.parser combinators.lib tools.vocabs debugger html continuations random combinators -destructors io.encodings.8-bit fry combinators.cleave ; +destructors io.encodings.8-bit fry ; IN: http.server GENERIC: call-responder ( path responder -- response ) diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index aea1bef930..a3d06e8f18 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -3,8 +3,8 @@ USING: assocs calendar kernel math.parser namespaces random 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 ! ! ! ! ! ! diff --git a/extra/http/server/sessions/storage/assoc/assoc.factor b/extra/http/server/sessions/storage/assoc/assoc.factor index f72f34e4d2..4bdc52b86e 100755 --- a/extra/http/server/sessions/storage/assoc/assoc.factor +++ b/extra/http/server/sessions/storage/assoc/assoc.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs assocs.lib accessors -http.server.sessions.storage combinators.cleave alarms kernel -fry http.server ; +USING: assocs assocs.lib accessors http.server.sessions.storage +alarms kernel fry http.server ; IN: http.server.sessions.storage.assoc TUPLE: sessions-in-memory sessions alarms ; diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor index 4d87aea5a3..471b7fa6df 100755 --- a/extra/http/server/sessions/storage/db/db.factor +++ b/extra/http/server/sessions/storage/db/db.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs accessors http.server.sessions.storage alarms kernel http.server db.tuples db.types singleton -combinators.cleave math.parser ; +math.parser ; IN: http.server.sessions.storage.db SINGLETON: sessions-in-db diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 2f48e7ac87..905c7320ca 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -3,8 +3,7 @@ USING: calendar html io io.files kernel math math.parser http http.server namespaces parser sequences strings assocs hashtables debugger http.mime sorting html.elements logging -calendar.format accessors io.encodings.binary -combinators.cleave fry ; +calendar.format accessors io.encodings.binary fry ; IN: http.server.static ! special maps mime types to quots with effect ( path -- ) diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor index b3710f6439..32a1125809 100755 --- a/extra/http/server/validators/validators.factor +++ b/extra/http/server/validators/validators.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel continuations sequences math namespaces -math.parser assocs regexp fry unicode.categories -combinators.cleave sequences ; +math.parser assocs regexp fry unicode.categories sequences ; IN: http.server.validators SYMBOL: validation-failed? diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index d29760a3e0..d2348fd4b0 100755 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -1,9 +1,8 @@ ! 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 combinators.cleave -generic parser tuples words io io.files splitting namespaces -math compiler.units accessors ; +USING: math.parser arrays io.encodings sequences kernel assocs +hashtables io.encodings.ascii generic parser tuples words io +io.files splitting namespaces math compiler.units accessors ; IN: io.encodings.8-bit ( root -- responder ) From 211749ed3de2d9140636bd96133767d64642d590 Mon Sep 17 00:00:00 2001 From: erg Date: Fri, 28 Mar 2008 23:20:33 -0500 Subject: [PATCH 274/886] re-add docs for random --- extra/random/random-docs.factor | 44 +++++++++++++++++++++++++++++++++ extra/random/random.factor | 2 +- 2 files changed, 45 insertions(+), 1 deletion(-) create mode 100644 extra/random/random-docs.factor diff --git a/extra/random/random-docs.factor b/extra/random/random-docs.factor new file mode 100644 index 0000000000..78c60fa2cb --- /dev/null +++ b/extra/random/random-docs.factor @@ -0,0 +1,44 @@ +USING: help.markup help.syntax math random.backend ; +IN: random + +ARTICLE: "random-numbers" "Generating random integers" +"The " { $vocab-link "random" } " vocabulary implements the ``Mersenne Twister'' pseudo-random number generator algorithm." +{ $subsection random } ; + +ABOUT: "random-numbers" + +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-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" } { "bytes" "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: random-bytes +{ $values { "n" "an integer" } { "bytes" "a random integer" } } +{ $description "Outputs an integer with n bytes worth of bits." } ; + +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 diff --git a/extra/random/random.factor b/extra/random/random.factor index e62ab71b92..c1701b1c0f 100755 --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -15,7 +15,7 @@ GENERIC: random-bytes* ( n tuple -- byte-array ) M: object random-bytes* ( n tuple -- byte-array ) swap [ drop random-32* ] with map >c-uint-array ; -M: object random-32* ( tuple -- n ) 4 random-bytes* le> ; +M: object random-32* ( tuple -- r ) 4 random-bytes* le> ; ERROR: no-random-number-generator ; From 2c3c66c6afa0871bda67ab740cb7ff574d77b7e5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Mar 2008 23:37:52 -0500 Subject: [PATCH 275/886] Update peg for words being moved --- extra/peg/peg.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 8f7522bda9..47ca60eef9 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,10 +1,9 @@ -! 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 math.parser match unicode.categories sequences.lib compiler.units parser - words quotations effects memoize accessors - combinators.cleave locals ; + words quotations effects memoize accessors locals ; IN: peg USE: prettyprint From ea45fe2b454ca53c96e28c2f010f4e24bd9b440c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Mar 2008 23:38:03 -0500 Subject: [PATCH 276/886] Move more cleave stuff into core --- core/combinators/combinators.factor | 20 ++++++ .../transforms/transforms-tests.factor | 24 +++++++ core/inference/transforms/transforms.factor | 6 ++ extra/combinators/cleave/cleave.factor | 70 ------------------- 4 files changed, 50 insertions(+), 70 deletions(-) diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 807b372e1d..305d03e3cb 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -5,6 +5,26 @@ USING: arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors hashtables sorting ; +: cleave ( obj seq -- ) + [ call ] with each ; + +: cleave>quot ( seq -- quot ) + [ [ keep ] curry ] map concat [ drop ] append ; + +: 2cleave ( obj seq -- ) + [ [ call ] 3keep drop ] each 2drop ; + +: 2cleave>quot ( seq -- quot ) + [ [ 2keep ] curry ] map concat [ 2drop ] append ; + +: spread>quot ( seq -- quot ) + [ length [ >r ] concat ] + [ [ [ r> ] prepend ] map concat ] bi + compose ; + +: spread ( seq -- ) + spread>quot call ; + ERROR: no-cond ; : cond ( assoc -- ) diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index 88aac780c1..54a81bfcdd 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -32,3 +32,27 @@ 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 + +: cleave-test { [ r>> ] [ g>> ] [ b>> ] } cleave ; + +{ 1 3 } [ cleave-test ] must-infer-as + +[ 1 2 3 ] [ 1 2 3 cleave-test ] unit-test + +[ 1 2 3 ] [ 1 2 3 \ 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 diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index b3a2bffcfe..e77872ae78 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -39,6 +39,12 @@ IN: inference.transforms ] if ] 1 define-transform +\ cleave [ cleave>quot ] 1 define-transform + +\ 2cleave [ 2cleave>quot ] 1 define-transform + +\ spread [ spread>quot ] 1 define-transform + ! Bitfields GENERIC: (bitfield-quot) ( spec -- quot ) diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index 1bc7480198..9ce7a1f553 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -3,76 +3,6 @@ USING: kernel sequences macros ; 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 - -: 2bi* ( w x y z p q -- p(x) q(y) ) >r -rot 2slip 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> ] prepend ] map concat - append ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Cleave into array ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From cbc68652176d66e0365052dca9318a6c993e9348 Mon Sep 17 00:00:00 2001 From: erg Date: Fri, 28 Mar 2008 23:40:18 -0500 Subject: [PATCH 277/886] fix teh docs --- extra/random/random-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/random/random-docs.factor b/extra/random/random-docs.factor index 78c60fa2cb..905f81b53d 100644 --- a/extra/random/random-docs.factor +++ b/extra/random/random-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax math random.backend ; +USING: help.markup help.syntax math ; IN: random ARTICLE: "random-numbers" "Generating random integers" From 86653e7a46d8da3862bfb520b335195c0065728e Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 29 Mar 2008 17:42:21 +1300 Subject: [PATCH 278/886] Don't use 'delay' parser in ebnf --- extra/peg/ebnf/ebnf.factor | 7 ++++--- extra/peg/peg.factor | 12 ++++++++++++ 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 76e851efd3..c1e2ce8546 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -262,8 +262,8 @@ M: ebnf-terminal (transform) ( ast -- parser ) M: ebnf-non-terminal (transform) ( ast -- parser ) symbol>> [ - , parser get , \ at , - ] [ ] make delay sp ; + , parser get , \ at , \ sp , + ] [ ] make box ; : transform-ebnf ( string -- object ) 'ebnf' parse parse-result-ast transform ; @@ -282,7 +282,8 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) : ebnf>quot ( string -- hashtable quot ) 'ebnf' parse check-parse-result - parse-result-ast transform dup main swap at compile [ compiled-parse ] curry ; + parse-result-ast transform dup dup parser [ main swap at compile ] with-variable + [ compiled-parse ] curry ; : [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index be4bba25fc..5ec934d994 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -489,6 +489,15 @@ M: delay-parser (compile) ( parser -- quot ) { } { "word" } memoize-quot [ % \ execute , ] [ ] make ; +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. + quot>> call compiled-parser 1quotation ; + PRIVATE> : token ( string -- parser ) @@ -557,6 +566,9 @@ PRIVATE> : delay ( quot -- parser ) delay-parser construct-boa init-parser ; +: box ( quot -- parser ) + box-parser construct-boa init-parser ; + : PEG: (:) [ [ From 8105e66aece2f6c466523542c0c04b0553d79b67 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 29 Mar 2008 17:45:21 +1300 Subject: [PATCH 279/886] Add box parser to docs --- extra/peg/peg-docs.factor | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index d2ca353ba1..7b13e06d5a 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -159,4 +159,17 @@ HELP: delay { $description "Delays the construction of a parser until it is actually required to parse. This " "allows for calling a parser that results in a recursive call to itself. The quotation " - "should return the constructed parser." } ; + "should return the constructed parser and is called the first time the parser is run." + "The compiled result is memoized for future runs. See " { $link box } " for a word " + "that calls the quotation at compile time." } ; + +HELP: box +{ $values + { "quot" "a quotation" } + { "parser" "a parser" } +} +{ $description + "Delays the construction of a parser until the parser is compiled. The quotation " + "should return the constructed parser and is called when the parser is compiled." + "The compiled result is memoized for future runs. See " { $link delay } " for a word " + "that calls the quotation at runtime." } ; From ca4f77575611df8c4c6d6f53d1ac25372f8cac7f Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 29 Mar 2008 18:33:37 +1300 Subject: [PATCH 280/886] Fix PEG: --- extra/peg/peg.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 5ec934d994..6f2e5bce95 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -572,7 +572,7 @@ PRIVATE> : PEG: (:) [ [ - call compile 1quotation + call compile [ compiled-parse ] curry [ dup [ parse-result-ast ] [ "Parse failed" throw ] if ] append define ] with-compilation-unit From aec04edbdaa837e04efada721bf8119dcde0e3df Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Mar 2008 00:59:05 -0500 Subject: [PATCH 281/886] Phasing out get-slots and cleaning up some code --- core/classes/mixin/mixin.factor | 5 +- core/combinators/combinators.factor | 2 +- core/continuations/continuations.factor | 15 +-- core/heaps/heaps.factor | 4 +- .../transforms/transforms-tests.factor | 2 +- core/io/encodings/encodings.factor | 12 +- core/parser/parser.factor | 15 +-- extra/calendar/calendar.factor | 4 +- extra/combinators/cleave/cleave-docs.factor | 108 ------------------ extra/io/buffers/buffers-docs.factor | 26 +---- extra/io/buffers/buffers-tests.factor | 44 ++----- extra/io/buffers/buffers.factor | 44 ++----- extra/io/nonblocking/nonblocking.factor | 34 +----- extra/io/unix/backend/backend.factor | 33 +++--- extra/io/unix/select/select.factor | 18 +-- extra/locals/locals.factor | 8 +- 16 files changed, 89 insertions(+), 285 deletions(-) delete mode 100644 extra/combinators/cleave/cleave-docs.factor diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 780f76f0f8..85a6fb241d 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -1,7 +1,7 @@ ! 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: mixin-class < union-class "mixin" word-prop ; @@ -53,8 +53,7 @@ M: mixin-instance equal? } cond 2nip ; M: mixin-instance hashcode* - { mixin-instance-class mixin-instance-mixin } get-slots - 2array hashcode* ; + [ class>> ] [ mixin>> ] bi 2array hashcode* ; : ( class mixin -- definition ) { set-mixin-instance-class set-mixin-instance-mixin } diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 305d03e3cb..cc03955fd8 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -20,7 +20,7 @@ hashtables sorting ; : spread>quot ( seq -- quot ) [ length [ >r ] concat ] [ [ [ r> ] prepend ] map concat ] bi - compose ; + append ; : spread ( seq -- ) spread>quot call ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 13b31cfde6..a2c296e8ce 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -1,7 +1,8 @@ ! 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 @@ -43,12 +44,12 @@ C: continuation : >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 diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index caab0d8f8e..34a4dc0d49 100755 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -2,7 +2,7 @@ ! 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 @@ -161,7 +161,7 @@ M: priority-queue heap-push* ( value key heap -- entry ) [ 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< ; diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index 54a81bfcdd..cb8024d3c5 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -1,6 +1,6 @@ IN: inference.transforms.tests USING: sequences inference.transforms tools.test math kernel -quotations inference ; +quotations inference accessors combinators words arrays ; : compose-n-quot >quotation ; : compose-n compose-n-quot call ; diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index a781b63ad5..2ef26096e0 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -1,9 +1,9 @@ ! 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 splitting -io.streams.duplex byte-arrays sequences.private ; +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 @@ -34,7 +34,7 @@ M: tuple-class construct-empty ; M: tuple f decoder construct-boa ; : >decoder< ( decoder -- stream encoding ) - { decoder-stream decoder-code } get-slots ; + [ stream>> ] [ code>> ] bi ; : cr+ t swap set-decoder-cr ; inline @@ -108,7 +108,7 @@ M: tuple-class construct-empty ; M: tuple encoder construct-boa ; : >encoder< ( encoder -- stream encoding ) - { encoder-stream encoder-code } get-slots ; + [ stream>> ] [ code>> ] bi ; M: encoder stream-write1 >encoder< encode-char ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 08f4275e49..6bae4e95b4 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -5,16 +5,18 @@ 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 ; +source-files classes hashtables compiler.errors compiler.units +accessors ; 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 ; : ( text -- lexer ) 0 { set-lexer-text set-lexer-line } lexer construct @@ -159,8 +161,7 @@ TUPLE: parse-error file line col text ; : ( msg -- error ) file get - lexer get - { lexer-line lexer-column lexer-line-text } get-slots + lexer get [ line>> ] [ column>> ] [ line-text>> ] tri parse-error construct-boa [ set-delegate ] keep ; diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 06425975d4..6d7007c54a 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -84,10 +84,10 @@ PRIVATE> ] ; : >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 ; : years ( n -- dt ) instant swap >>year ; diff --git a/extra/combinators/cleave/cleave-docs.factor b/extra/combinators/cleave/cleave-docs.factor deleted file mode 100644 index 46e9abcd9f..0000000000 --- a/extra/combinators/cleave/cleave-docs.factor +++ /dev/null @@ -1,108 +0,0 @@ - -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 diff --git a/extra/io/buffers/buffers-docs.factor b/extra/io/buffers/buffers-docs.factor index 5ce9b71427..a11a7adead 100755 --- a/extra/io/buffers/buffers-docs.factor +++ b/extra/io/buffers/buffers-docs.factor @@ -18,9 +18,7 @@ $nl "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 } @@ -47,10 +45,6 @@ HELP: buffer-free { $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" } "." } ; @@ -67,17 +61,13 @@ HELP: buffer-end { $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" } } @@ -103,7 +93,7 @@ HELP: check-overflow 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 } } @@ -121,7 +111,3 @@ HELP: buffer-peek 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 } "." } ; diff --git a/extra/io/buffers/buffers-tests.factor b/extra/io/buffers/buffers-tests.factor index 1f3e262fed..f66f9ed313 100755 --- a/extra/io/buffers/buffers-tests.factor +++ b/extra/io/buffers/buffers-tests.factor @@ -1,6 +1,6 @@ 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 @@ -9,24 +9,29 @@ sequences tools.test namespaces byte-arrays strings ; : string>buffer ( string -- buffer ) dup length tuck buffer-set ; +: buffer-read-all ( buffer -- byte-array ) + [ [ pos>> ] [ ptr>> ] bi ] + [ buffer-length ] bi + memory>byte-array ; + [ B{ } 65536 ] [ 65536 - 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 ] [ @@ -37,7 +42,7 @@ sequences tools.test namespaces byte-arrays strings ; [ "hello world" ] [ "hello" 1024 [ 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 ] [ @@ -45,33 +50,8 @@ sequences tools.test namespaces byte-arrays strings ; 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 "b" set diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index 7d51d04d7b..8b00e59d23 100755 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -3,7 +3,8 @@ ! 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 ; @@ -37,46 +38,21 @@ TUPLE: buffer size ptr fill pos ; : 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 - 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 @@ -93,7 +69,7 @@ HINTS: search-buffer-until { fixnum fixnum simple-alien string } ; : 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 diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index ed98665e06..b345a98e88 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -73,7 +73,7 @@ M: input-port stream-read1 : read-step ( count port -- byte-array/f ) [ wait-to-read ] 2keep - [ dupd buffer> ] unless-eof nip ; + [ dupd buffer-read ] unless-eof nip ; : read-loop ( count port accum -- ) pick over length - dup 0 > [ @@ -101,38 +101,6 @@ M: input-port stream-read 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 ; - M: input-port stream-read-partial ( max stream -- byte-array/f ) >r 0 max >fixnum r> read-step ; diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index c9bd331bcd..63d2adbdf7 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -4,7 +4,7 @@ USING: alien generic assocs kernel kernel.private math 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 @@ -13,7 +13,7 @@ MIXIN: unix-io ! I/O tasks TUPLE: io-task port callbacks ; -: io-task-fd io-task-port port-handle ; +: io-task-fd port>> handle>> ; : ( port continuation/f class -- task ) >r [ 1vector ] [ V{ } clone ] if* io-task construct-boa @@ -35,9 +35,9 @@ 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 ) f H{ } clone H{ } clone mx construct-boa ; @@ -90,11 +90,11 @@ M: integer close-handle ( fd -- ) 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. @@ -110,26 +110,25 @@ M: integer close-handle ( fd -- ) : 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 -- ) mx get-global cancel-io-tasks ; ! Readers : reader-eof ( reader -- ) - dup buffer-empty? [ t over set-port-eof? ] when drop ; + dup buffer-empty? [ t >>eof? ] when drop ; : (refill) ( port -- n ) - dup port-handle over buffer-end rot buffer-capacity read ; + [ handle>> ] [ buffer-end ] [ buffer-capacity ] tri read ; : refill ( port -- ? ) #! Return f if there is a recoverable error @@ -158,7 +157,7 @@ M: input-port (wait-to-read) ! Writers : write-step ( port -- ? ) - dup port-handle over buffer@ pick buffer-length write + dup [ handle>> ] [ buffer@ ] [ buffer-length ] tri write dup 0 >= [ swap buffer-consume f ] [ drop defer-error ] if ; TUPLE: write-task ; @@ -167,7 +166,7 @@ TUPLE: write-task ; write-task ; M: write-task do-io-task - io-task-port dup buffer-empty? over port-error or + io-task-port dup [ buffer-empty? ] [ port-error ] bi or [ 0 swap buffer-reset t ] [ write-step ] if ; : add-write-io-task ( port continuation -- ) @@ -193,7 +192,7 @@ M: unix-io (init-stdio) ( -- ) TUPLE: mx-port mx ; : ( mx -- port ) - dup mx-fd f mx-port + dup fd>> f mx-port { set-mx-port-mx set-delegate } mx-port construct ; TUPLE: mx-task ; @@ -202,7 +201,7 @@ TUPLE: mx-task ; f mx-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 ; diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index 77a20beb42..aceee0f311 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -1,7 +1,8 @@ ! 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 ; @@ -14,11 +15,11 @@ TUPLE: select-mx read-fdset write-fdset ; : ( -- mx ) select-mx construct-mx - FD_SETSIZE 8 * over set-select-mx-read-fdset - FD_SETSIZE 8 * over set-select-mx-write-fdset ; + FD_SETSIZE 8 * >>read-fdset + FD_SETSIZE 8 * >>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 @@ -32,15 +33,16 @@ TUPLE: select-mx read-fdset write-fdset ; [ >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 diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 25f9e4eaf9..5da0225be9 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -266,13 +266,13 @@ M: object local-rewrite* , ; ] assoc-each local-rewrite* \ call , ; M: let local-rewrite* - { body>> bindings>> } get-slots let-rewrite ; + [ body>> ] [ bindings>> ] bi let-rewrite ; M: let* local-rewrite* - { body>> bindings>> } get-slots let-rewrite ; + [ body>> ] [ bindings>> ] bi let-rewrite ; M: wlet local-rewrite* - { body>> bindings>> } get-slots + [ body>> ] [ bindings>> ] bi [ [ ] curry ] assoc-map let-rewrite ; @@ -340,7 +340,7 @@ M: lambda pprint* : pprint-let ( let word -- ) pprint-word - { body>> bindings>> } get-slots + [ body>> ] [ bindings>> ] bi \ | pprint-word t Date: Sat, 29 Mar 2008 02:46:29 -0500 Subject: [PATCH 282/886] Clean up tuple code and get hierarchy changes working --- core/classes/classes.factor | 21 ++++++---- core/classes/union/union.factor | 4 +- core/prettyprint/prettyprint.factor | 2 +- core/tuples/tuples-tests.factor | 4 +- core/tuples/tuples.factor | 64 ++++++++++++++--------------- extra/json/writer/writer.factor | 2 +- 6 files changed, 51 insertions(+), 46 deletions(-) diff --git a/core/classes/classes.factor b/core/classes/classes.factor index ccb735f392..435c7413a3 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -101,12 +101,12 @@ M: word reset-class drop ; PRIVATE> -GENERIC: update-predicate ( class -- ) +GENERIC: update-class ( class -- ) -M: class update-predicate drop ; +M: class update-class drop ; -: update-predicates ( assoc -- ) - [ drop update-predicate ] assoc-each ; +: update-classes ( assoc -- ) + [ drop update-class ] assoc-each ; GENERIC: update-methods ( assoc -- ) @@ -114,10 +114,15 @@ GENERIC: update-methods ( assoc -- ) #! If it was already a class, update methods after. reset-caches define-class-props - over update-map- - dupd (define-class) - dup update-map+ - class-usages dup update-predicates update-methods ; + [ drop update-map- ] + [ (define-class) ] [ + drop + [ update-map+ ] [ + class-usages + [ update-classes ] + [ update-methods ] bi + ] bi + ] 2tri ; GENERIC: class ( object -- class ) inline diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 814ab0e838..e9b98770dc 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -33,10 +33,10 @@ PREDICATE: union-class < class : 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 -- ) - >r dup f r> union-class define-class define-union-predicate ; + f swap union-class define-class ; M: union-class reset-class { "metaclass" "members" } reset-props ; diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 7b8c8f2997..675841816f 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -260,7 +260,7 @@ M: tuple-class see-class* dup superclass tuple eq? [ "<" text dup superclass pprint-word ] unless - "slot-names" word-prop [ text ] each + slot-names [ text ] each pprint-; block> ; M: word see-class* drop ; diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index 09795888a8..2ae53ee05d 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -343,7 +343,7 @@ TUPLE: electronic-device ; ! Hardcore unit tests USE: threads -\ thread "slot-names" word-prop "slot-names" set +\ thread slot-names "slot-names" set [ ] [ [ @@ -361,7 +361,7 @@ USE: threads USE: vocabs -\ vocab "slot-names" word-prop "slot-names" set +\ vocab slot-names "slot-names" set [ ] [ [ diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 60606357d3..f4ab215bf0 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -4,7 +4,7 @@ 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 ; +compiler.units math.private accessors ; IN: tuples M: tuple delegate 2 slot ; @@ -44,6 +44,9 @@ PRIVATE> 2each ] keep ; +: slot-names ( class -- seq ) + "slots" word-prop [ name>> ] map ; + : superclass-size ( class -- n ) superclasses 1 head-slice* - [ "slot-names" word-prop length ] map sum ; + [ slot-names length ] map sum ; -: generate-tuple-slots ( class slots -- slot-specs slot-names ) - over superclass-size 2 + simple-slots - dup [ slot-spec-name ] map ; +: generate-tuple-slots ( class slots -- slots ) + over superclass-size 2 + simple-slots ; : define-tuple-slots ( class slots -- ) dupd generate-tuple-slots - >r dupd "slots" set-word-prop - r> dupd "slot-names" set-word-prop - dup "slots" word-prop 2dup define-slots define-accessors ; + [ "slots" set-word-prop ] + [ define-accessors ] + [ define-slots ] 2tri ; : make-tuple-layout ( class -- layout ) - dup superclass-size over "slot-names" word-prop length + - over superclasses dup length 1- ; + [ ] + [ [ superclass-size ] [ "slots" word-prop length ] bi + ] + [ superclasses dup length 1- ] tri + ; : define-tuple-layout ( class -- ) dup make-tuple-layout "layout" set-word-prop ; : removed-slots ( class newslots -- seq ) - swap "slot-names" word-prop seq-diff ; + swap slot-names seq-diff ; -: forget-slots ( class newslots -- ) +: forget-slots ( class slots -- ) dupd removed-slots [ - 2dup - reader-word forget-method - writer-word forget-method + [ reader-word forget-method ] + [ writer-word forget-method ] 2bi ] with each ; : permutation ( seq1 seq2 -- permutation ) @@ -126,28 +129,29 @@ PRIVATE> : reshape-tuples ( class superclass newslots -- ) nip - >r dup "slot-names" word-prop r> permutation + >r dup slot-names r> permutation [ - >r [ swap class eq? ] curry instances dup r> - [ reshape-tuple ] curry map + >r "predicate" word-prop instances dup + r> [ reshape-tuple ] curry map become ] 2curry after-compilation ; : define-new-tuple-class ( class superclass slots -- ) [ drop f tuple-class define-class ] - [ nip define-tuple-slots ] - [ + [ nip define-tuple-slots ] [ 2drop - [ define-tuple-layout ] - [ define-tuple-predicate ] - bi - ] - 3tri ; + class-usages [ + drop + [ define-tuple-layout ] + [ define-tuple-predicate ] + bi + ] assoc-each + ] 3tri ; : redefine-tuple-class ( class superclass slots -- ) [ reshape-tuples ] [ - drop + nip [ forget-slots ] [ drop changed-word ] [ drop redefined ] @@ -157,9 +161,7 @@ PRIVATE> 3tri ; : tuple-class-unchanged? ( class superclass slots -- ? ) - rot tuck - [ "superclass" word-prop = ] - [ "slot-names" word-prop = ] 2bi* and ; + rot tuck [ superclass = ] [ slot-names = ] 2bi* and ; PRIVATE> @@ -199,9 +201,7 @@ M: tuple hashcode* ! Definition protocol M: tuple-class reset-class - { - "metaclass" "superclass" "slot-names" "slots" "layout" - } reset-props ; + { "metaclass" "superclass" "slots" "layout" } reset-props ; M: object get-slots ( obj slots -- ... ) [ execute ] with each ; diff --git a/extra/json/writer/writer.factor b/extra/json/writer/writer.factor index 4f3bd09613..110e9b843c 100644 --- a/extra/json/writer/writer.factor +++ b/extra/json/writer/writer.factor @@ -42,7 +42,7 @@ M: sequence json-print ( array -- string ) : 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 ; + [ tuple-slots ] keep class slot-names ; : slots>fields ( values names -- array ) #! Convert the arrays containing the slot names and values From adb1dd14d0f696ff7ed5bc8b09559b7e263b51c4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Mar 2008 03:34:48 -0500 Subject: [PATCH 283/886] Rename tuples vocab to classes.tuple for consistency --- core/alien/alien.factor | 3 +- core/bootstrap/compiler/compiler.factor | 4 +-- core/bootstrap/image/image.factor | 9 +++--- core/bootstrap/layouts/layouts.factor | 2 +- core/bootstrap/primitives.factor | 30 +++++++++---------- core/{tuples => classes/tuple}/authors.txt | 0 core/{tuples => classes/tuple}/summary.txt | 0 .../tuple/tuple-docs.factor} | 6 ++-- .../tuple/tuple-tests.factor} | 30 +++++++++---------- .../tuple/tuple.factor} | 4 +-- core/cpu/arm/intrinsics/intrinsics.factor | 4 +-- core/cpu/ppc/intrinsics/intrinsics.factor | 6 ++-- core/cpu/x86/intrinsics/intrinsics.factor | 4 +-- core/debugger/debugger.factor | 2 +- core/inference/inference-tests.factor | 6 ++-- core/inference/known-words/known-words.factor | 6 ++-- core/inference/transforms/transforms.factor | 2 +- core/kernel/kernel.factor | 2 -- core/listener/listener.factor | 2 +- core/mirrors/mirrors.factor | 2 +- core/optimizer/known-words/known-words.factor | 2 +- core/optimizer/optimizer-tests.factor | 2 +- core/parser/parser-tests.factor | 3 +- core/prettyprint/backend/backend.factor | 3 +- core/prettyprint/prettyprint.factor | 4 +-- core/refs/refs.factor | 6 ++-- core/slots/slots-docs.factor | 2 +- core/syntax/syntax-docs.factor | 4 +-- core/syntax/syntax.factor | 2 +- core/vocabs/loader/loader-tests.factor | 2 +- core/words/words-tests.factor | 3 +- extra/bake/bake.factor | 2 +- extra/calendar/calendar.factor | 4 +-- .../{tuples => classes/tuple}/lib/authors.txt | 0 .../tuple}/lib/lib-docs.factor | 6 ++-- .../tuple}/lib/lib-tests.factor | 4 +-- .../{tuples => classes/tuple}/lib/lib.factor | 2 +- extra/db/db.factor | 2 +- extra/db/sql/sql.factor | 2 +- extra/db/sqlite/sqlite.factor | 2 +- extra/db/tuples/tuples.factor | 2 +- extra/db/types/types.factor | 2 +- extra/editors/editors.factor | 4 +-- extra/help/help.factor | 6 ++-- .../http/server/components/components.factor | 10 +++---- extra/inverse/inverse.factor | 5 ++-- extra/io/encodings/8-bit/8-bit.factor | 4 +-- extra/io/nonblocking/nonblocking-docs.factor | 8 ----- extra/io/windows/nt/backend/backend.factor | 2 +- extra/io/windows/nt/sockets/sockets.factor | 2 +- extra/json/writer/writer.factor | 2 +- extra/match/match.factor | 2 +- extra/models/models-docs.factor | 2 +- extra/serialize/serialize.factor | 12 ++++---- .../disassembler/disassembler-tests.factor | 2 +- extra/tuple-arrays/tuple-arrays.factor | 3 +- extra/ui/gadgets/buttons/buttons.factor | 4 +-- extra/ui/gadgets/canvas/canvas.factor | 2 +- extra/ui/gadgets/frames/frames-docs.factor | 2 +- extra/ui/gadgets/gadgets-docs.factor | 2 +- extra/ui/gadgets/labelled/labelled.factor | 3 +- extra/ui/gadgets/lists/lists.factor | 2 +- extra/ui/gadgets/packs/packs-docs.factor | 4 +-- extra/ui/gadgets/panes/panes.factor | 2 +- .../presentations/presentations-tests.factor | 2 +- extra/ui/gadgets/scrollers/scrollers.factor | 2 +- extra/ui/gadgets/tracks/tracks-docs.factor | 2 +- extra/ui/gestures/gestures.factor | 3 +- extra/ui/tools/interactor/interactor.factor | 2 +- extra/ui/tools/search/search.factor | 2 +- extra/ui/x11/x11.factor | 2 +- 71 files changed, 141 insertions(+), 144 deletions(-) rename core/{tuples => classes/tuple}/authors.txt (100%) rename core/{tuples => classes/tuple}/summary.txt (100%) rename core/{tuples/tuples-docs.factor => classes/tuple/tuple-docs.factor} (98%) rename core/{tuples/tuples-tests.factor => classes/tuple/tuple-tests.factor} (89%) rename core/{tuples/tuples.factor => classes/tuple/tuple.factor} (98%) rename extra/{tuples => classes/tuple}/lib/authors.txt (100%) rename extra/{tuples => classes/tuple}/lib/lib-docs.factor (86%) rename extra/{tuples => classes/tuple}/lib/lib-tests.factor (70%) rename extra/{tuples => classes/tuple}/lib/lib.factor (94%) diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 777bf523a5..d0adec1fcf 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -1,8 +1,7 @@ ! 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 -arrays ; +kernel.private bit-arrays byte-arrays float-arrays arrays ; IN: alien ! Some predicate classes used by the compiler for optimization diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index af2cc79579..7d4db3c473 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -2,8 +2,8 @@ ! 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 diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 7fd4361246..deb54fdeeb 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -4,10 +4,11 @@ USING: alien arrays bit-arrays byte-arrays generic assocs 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 tuples.private 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.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 ) diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index 316fa3cd72..846cce153b 100755 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -2,7 +2,7 @@ ! 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 tuples.private ; +float-arrays quotations assocs layouts classes.tuple.private ; BIN: 111 tag-mask set 8 num-tags set diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 50dea27e7b..2e1a7f9f57 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -2,10 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays byte-arrays generic hashtables hashtables.private io kernel math namespaces parser sequences -strings vectors words quotations assocs layouts classes tuples -tuples.private kernel.private vocabs vocabs.loader source-files -definitions slots.deprecated classes.union compiler.units -bootstrap.image.private io.files ; +strings vectors words quotations assocs layouts classes +classes.tuple classes.tuple.private kernel.private vocabs +vocabs.loader source-files definitions slots.deprecated +classes.union compiler.units bootstrap.image.private io.files ; IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush @@ -60,6 +60,8 @@ num-types get f builtins set "byte-arrays" "byte-vectors" "classes.private" + "classes.tuple" + "classes.tuple.private" "compiler.units" "continuations.private" "float-arrays" @@ -91,8 +93,6 @@ num-types get f builtins set "system.private" "threads.private" "tools.profiler.private" - "tuples" - "tuples.private" "words" "words.private" "vectors" @@ -291,35 +291,35 @@ define-builtin "callstack" "kernel" create { } define-builtin -"tuple-layout" "tuples.private" create { +"tuple-layout" "classes.tuple.private" create { { { "fixnum" "math" } "hashcode" - { "layout-hashcode" "tuples.private" } + { "layout-hashcode" "classes.tuple.private" } f } { { "word" "words" } "class" - { "layout-class" "tuples.private" } + { "layout-class" "classes.tuple.private" } f } { { "fixnum" "math" } "size" - { "layout-size" "tuples.private" } + { "layout-size" "classes.tuple.private" } f } { { "array" "arrays" } "superclasses" - { "layout-superclasses" "tuples.private" } + { "layout-superclasses" "classes.tuple.private" } f } { { "fixnum" "math" } "echelon" - { "layout-echelon" "tuples.private" } + { "layout-echelon" "classes.tuple.private" } f } } define-builtin @@ -694,13 +694,13 @@ dup tuple-layout [ ] curry define { "" "strings" } { "array>quotation" "quotations.private" } { "quotation-xt" "quotations" } - { "" "tuples.private" } - { "" "tuples.private" } + { "" "classes.tuple.private" } + { "" "classes.tuple.private" } { "profiling" "tools.profiler.private" } { "become" "kernel.private" } { "(sleep)" "threads.private" } { "" "float-arrays" } - { "" "tuples.private" } + { "" "classes.tuple.private" } { "class-hash" "kernel.private" } { "callstack>array" "kernel" } { "innermost-frame-quot" "kernel.private" } diff --git a/core/tuples/authors.txt b/core/classes/tuple/authors.txt similarity index 100% rename from core/tuples/authors.txt rename to core/classes/tuple/authors.txt diff --git a/core/tuples/summary.txt b/core/classes/tuple/summary.txt similarity index 100% rename from core/tuples/summary.txt rename to core/classes/tuple/summary.txt diff --git a/core/tuples/tuples-docs.factor b/core/classes/tuple/tuple-docs.factor similarity index 98% rename from core/tuples/tuples-docs.factor rename to core/classes/tuple/tuple-docs.factor index 55e15d6dc6..a747008fa2 100755 --- a/core/tuples/tuples-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -1,7 +1,7 @@ USING: generic help.markup help.syntax kernel -tuples.private classes slots quotations words arrays +classes.tuple.private classes slots quotations words arrays generic.standard sequences definitions compiler.units ; -IN: tuples +IN: classes.tuple ARTICLE: "tuple-constructors" "Constructors" "Tuples are created by calling one of two words:" @@ -151,7 +151,7 @@ HELP: set-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." } ; +{ $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: permutation { $values { "seq1" sequence } { "seq2" sequence } { "permutation" "a sequence whose elements are integers or " { $link f } } } diff --git a/core/tuples/tuples-tests.factor b/core/classes/tuple/tuple-tests.factor similarity index 89% rename from core/tuples/tuples-tests.factor rename to core/classes/tuple/tuple-tests.factor index 2ae53ee05d..2e37655f1d 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -1,10 +1,10 @@ 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 accessors classes.algebra calendar -prettyprint io.streams.string splitting ; -IN: tuples.tests +generic.standard effects classes.tuple classes.tuple.private +arrays vectors strings compiler.units accessors classes.algebra +calendar prettyprint io.streams.string splitting ; +IN: classes.tuple.tests TUPLE: rect x y w h ; : rect construct-boa ; @@ -44,7 +44,7 @@ C: redefinition-test [ t ] [ "redefinition-test" get redefinition-test? ] unit-test -"IN: tuples.tests TUPLE: redefinition-test ;" eval +"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval [ t ] [ "redefinition-test" get redefinition-test? ] unit-test @@ -56,7 +56,7 @@ C: point [ ] [ 100 200 "p" set ] unit-test ! Use eval to sequence parsing explicitly -[ ] [ "IN: tuples.tests TUPLE: point x y z ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval ] unit-test [ 100 ] [ "p" get x>> ] unit-test [ 200 ] [ "p" get y>> ] unit-test @@ -68,7 +68,7 @@ C: point [ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test -"IN: tuples.tests TUPLE: point z y ;" eval +"IN: classes.tuple.tests TUPLE: point z y ;" eval [ 3 ] [ "p" get tuple-size ] unit-test @@ -124,7 +124,7 @@ GENERIC: TUPLE: yo-momma ; -"IN: tuples.tests C: yo-momma" eval +"IN: classes.tuple.tests C: yo-momma" eval [ f ] [ \ generic? ] unit-test @@ -213,12 +213,12 @@ M: vector silly "z" ; SYMBOL: not-a-tuple-class [ - "IN: tuples.tests C: not-a-tuple-class" + "IN: classes.tuple.tests C: not-a-tuple-class" eval ] must-fail [ t ] [ - "not-a-tuple-class" "tuples.tests" lookup symbol? + "not-a-tuple-class" "classes.tuple.tests" lookup symbol? ] unit-test ! Missing check @@ -234,14 +234,14 @@ C: erg's-reshape-problem : cons-test-1 \ erg's-reshape-problem construct-empty ; : cons-test-2 \ erg's-reshape-problem construct-boa ; -"IN: tuples.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval +"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: tuples.tests SYMBOL: not-a-class C: not-a-class" eval + "IN: classes.tuple.tests SYMBOL: not-a-class C: not-a-class" eval ] [ [ no-tuple-class? ] is? ] must-fail-with ! Inheritance @@ -313,13 +313,13 @@ C: server ] unit-test [ - "IN: tuples.tests TUPLE: bad-superclass < word ;" eval + "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval ] must-fail ! Reshaping with inheritance TUPLE: electronic-device ; -[ ] [ "IN: tuples.tests TUPLE: computer < electronic-device ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device ;" eval ] unit-test [ f ] [ electronic-device laptop class< ] unit-test [ t ] [ server electronic-device class< ] unit-test @@ -335,7 +335,7 @@ TUPLE: electronic-device ; [ f ] [ "server" get laptop? ] unit-test [ t ] [ "server" get server? ] unit-test -[ ] [ "IN: tuples.tests TUPLE: computer ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer ;" eval ] unit-test [ f ] [ "laptop" get electronic-device? ] unit-test [ t ] [ "laptop" get computer? ] unit-test diff --git a/core/tuples/tuples.factor b/core/classes/tuple/tuple.factor similarity index 98% rename from core/tuples/tuples.factor rename to core/classes/tuple/tuple.factor index f4ab215bf0..28dbfdb372 100755 --- a/core/tuples/tuples.factor +++ b/core/classes/tuple/tuple.factor @@ -4,8 +4,8 @@ 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 ; -IN: tuples +compiler.units math.private accessors assocs ; +IN: classes.tuple M: tuple delegate 2 slot ; diff --git a/core/cpu/arm/intrinsics/intrinsics.factor b/core/cpu/arm/intrinsics/intrinsics.factor index 29210afaa5..e9902888eb 100755 --- a/core/cpu/arm/intrinsics/intrinsics.factor +++ b/core/cpu/arm/intrinsics/intrinsics.factor @@ -5,8 +5,8 @@ cpu.arm.architecture cpu.arm.allot kernel kernel.private math 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 diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 0aef15ba99..7aa78ce52e 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -6,9 +6,9 @@ kernel.private math math.private namespaces sequences words 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 diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index dfe136fc6e..f5409a24f5 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -6,8 +6,8 @@ kernel.private math math.private namespaces quotations sequences 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 diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 3361073d35..a7937cdb9d 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -3,7 +3,7 @@ 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 +classes.tuple continuations continuations.private combinators generic.math io.streams.duplex classes compiler.units generic.standard vocabs threads threads.private init kernel.private libc io.encodings ; diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 4f5d199264..1cc1548a3d 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -3,9 +3,9 @@ inference.dataflow kernel classes kernel.private math 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 { 0 2 } [ 2 "Hello" ] must-infer-as diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 0de1e0bc53..79e41c8ae4 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -9,9 +9,9 @@ kernel.private math math.private memory namespaces 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 diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index e77872ae78..200208c6a5 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -2,7 +2,7 @@ ! 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 +inference.dataflow inference.state classes.tuple.private effects inspector hashtables ; IN: inference.transforms diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 1987597c58..cbabeb6bfa 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -156,8 +156,6 @@ GENERIC: construct-boa ( ... class -- tuple ) >r { set-delegate } r> construct ; inline ! Quotation building -USE: tuples.private - : 2curry ( obj1 obj2 quot -- curry ) curry curry ; inline diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 16ee2705fe..bf262b77a2 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -3,7 +3,7 @@ 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 ; IN: listener SYMBOL: quit-flag diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index 3c5a0aa3c7..fde8728858 100755 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -1,7 +1,7 @@ ! 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 +arrays classes slots slots.private classes.tuple math vectors quotations sorting prettyprint ; IN: mirrors diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index b56f6fdb06..aef48452de 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -6,7 +6,7 @@ inference.class kernel assocs math math.private kernel.private 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 +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 ; diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 89cea45aee..aa081e8e2c 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -2,7 +2,7 @@ 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 classes.algebra inference.dataflow -tuples.private continuations growable optimizer.inlining +classes.tuple.private continuations growable optimizer.inlining namespaces hints ; IN: optimizer.tests diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 670740fff0..a15da82718 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -1,7 +1,8 @@ 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 vocabs.loader ; +sorting classes.tuple compiler.units debugger vocabs +vocabs.loader ; IN: parser.tests [ diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index 5d7b967fc4..c9019b029d 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -4,7 +4,8 @@ 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 tuples.private classes float-arrays float-vectors ; +classes.tuple classes.tuple.private classes float-arrays +float-vectors ; IN: prettyprint.backend GENERIC: pprint* ( obj -- ) diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 675841816f..6c557d873d 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -1,11 +1,11 @@ -! 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 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 +definitions effects classes.tuple io.files classes continuations hashtables classes.mixin classes.union classes.predicate combinators quotations ; diff --git a/core/refs/refs.factor b/core/refs/refs.factor index fb67db9332..c52c5daf9e 100644 --- a/core/refs/refs.factor +++ b/core/refs/refs.factor @@ -1,6 +1,6 @@ -! 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 ; @@ -8,7 +8,7 @@ TUPLE: ref assoc key ; : ( assoc key class -- tuple ) >r ref construct-boa r> construct-delegate ; inline -: >ref< ( ref -- key assoc ) dup ref-key swap ref-assoc ; +: >ref< ( ref -- key assoc ) [ key>> ] [ assoc>> ] bi ; : delete-ref ( ref -- ) >ref< delete-at ; GENERIC: get-ref ( ref -- obj ) diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 5de765313b..2b0d721f3e 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax generic kernel.private parser words kernel quotations namespaces sequences words arrays -effects generic.standard tuples slots.private classes +effects generic.standard classes.tuple slots.private classes strings math ; IN: slots diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 3874cecf71..bd349953df 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -1,6 +1,6 @@ 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 +arrays io.files vocabs.loader io sequences assocs ; IN: syntax ARTICLE: "parser-algorithm" "Parser algorithm" diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 5da2d5e4e2..19fdf0e45f 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -3,7 +3,7 @@ USING: alien arrays bit-arrays bit-vectors byte-arrays byte-vectors definitions generic hashtables kernel math namespaces parser sequences strings sbufs vectors words -quotations io assocs splitting tuples generic.standard +quotations io assocs splitting classes.tuple generic.standard generic.math classes io.files vocabs float-arrays float-vectors classes.union classes.mixin classes.predicate compiler.units combinators debugger ; diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 85399ca9e7..fd3b616b87 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -2,7 +2,7 @@ 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 +parser source-files words assocs classes.tuple definitions debugger compiler.units tools.vocabs ; ! This vocab should not exist, but just in case... diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 4d9933147b..cef6b19943 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -1,6 +1,7 @@ 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 ; IN: words.tests [ 4 ] [ diff --git a/extra/bake/bake.factor b/extra/bake/bake.factor index 19d89f67f0..987122f05c 100644 --- a/extra/bake/bake.factor +++ b/extra/bake/bake.factor @@ -1,6 +1,6 @@ USING: kernel parser namespaces quotations arrays vectors strings - sequences assocs tuples math combinators ; + sequences assocs classes.tuple math combinators ; IN: bake diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 6d7007c54a..0a808f53bd 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -2,8 +2,8 @@ ! 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 -accessors combinators locals ; +strings system vocabs.loader calendar.backend threads +accessors combinators locals classes.tuple ; IN: calendar TUPLE: timestamp year month day hour minute second gmt-offset ; diff --git a/extra/tuples/lib/authors.txt b/extra/classes/tuple/lib/authors.txt similarity index 100% rename from extra/tuples/lib/authors.txt rename to extra/classes/tuple/lib/authors.txt diff --git a/extra/tuples/lib/lib-docs.factor b/extra/classes/tuple/lib/lib-docs.factor similarity index 86% rename from extra/tuples/lib/lib-docs.factor rename to extra/classes/tuple/lib/lib-docs.factor index 75df1550f4..20431da07b 100644 --- a/extra/tuples/lib/lib-docs.factor +++ b/extra/classes/tuple/lib/lib-docs.factor @@ -1,11 +1,11 @@ USING: help.syntax help.markup kernel prettyprint sequences ; -IN: tuples.lib +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 tuples.lib ;" + "USING: kernel prettyprint classes.tuple.lib ;" "TUPLE: foo a b c ;" "1 2 3 \\ foo construct-boa \\ foo >tuple< .s" "1\n2\n3" @@ -17,7 +17,7 @@ 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 ;" + "USING: kernel prettyprint classes.tuple.lib ;" "TUPLE: foo a bb* ccc dddd* ;" "1 2 3 4 \\ foo construct-boa \\ foo >tuple*< .s" "2\n4" diff --git a/extra/tuples/lib/lib-tests.factor b/extra/classes/tuple/lib/lib-tests.factor similarity index 70% rename from extra/tuples/lib/lib-tests.factor rename to extra/classes/tuple/lib/lib-tests.factor index 5d90f25bd7..328f83d714 100644 --- a/extra/tuples/lib/lib-tests.factor +++ b/extra/classes/tuple/lib/lib-tests.factor @@ -1,5 +1,5 @@ -USING: kernel tools.test tuples.lib ; -IN: tuples.lib.tests +USING: kernel tools.test classes.tuple.lib ; +IN: classes.tuple.lib.tests TUPLE: foo a b* c d* e f* ; diff --git a/extra/tuples/lib/lib.factor b/extra/classes/tuple/lib/lib.factor similarity index 94% rename from extra/tuples/lib/lib.factor rename to extra/classes/tuple/lib/lib.factor index 4c007c8bb1..38104a45db 100755 --- a/extra/tuples/lib/lib.factor +++ b/extra/classes/tuple/lib/lib.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel macros sequences slots words mirrors ; -IN: tuples.lib +IN: classes.tuple.lib : reader-slots ( seq -- quot ) [ slot-spec-reader ] map [ get-slots ] curry ; diff --git a/extra/db/db.factor b/extra/db/db.factor index f9e946fc20..55e672ec80 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -1,7 +1,7 @@ ! 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 +namespaces sequences sequences.lib classes.tuple words strings tools.walker accessors ; IN: db diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor index 1de4bdfb5a..99dde99280 100755 --- a/extra/db/sql/sql.factor +++ b/extra/db/sql/sql.factor @@ -1,4 +1,4 @@ -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 diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index c81448865f..9b3185bcf2 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -2,7 +2,7 @@ ! 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 io namespaces.lib ; diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 00e8ed8b76..7fc059c9b3 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -1,7 +1,7 @@ ! 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 math.parser io prettyprint db.types continuations mirrors sequences.lib tools.walker combinators.lib ; IN: db.tuples diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 94a8d6f392..3c73a933e9 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -3,7 +3,7 @@ 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 +mirrors classes.tuple combinators calendar.format symbols singleton ; IN: db.types diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index bfbfe1b6ca..85d58e7572 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -1,9 +1,9 @@ ! 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 +inspector continuations tools.crossref tools.vocabs io prettyprint source-files assocs vocabs vocabs.loader -io.backend splitting ; +io.backend splitting classes.tuple ; IN: editors TUPLE: no-edit-hook ; diff --git a/extra/help/help.factor b/extra/help/help.factor index 9e4d02802b..4e8424f7a3 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -2,9 +2,9 @@ ! 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 ) diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 828ff8e562..bd95bf4407 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: 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 -fry continuations math ; +USING: html.elements http.server.validators accessors namespaces +kernel io math.parser assocs classes words classes.tuple arrays +sequences io.files http.server.templating.fhtml +http.server.actions splitting mirrors hashtables fry +continuations math ; IN: http.server.components SYMBOL: components diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 308bf36bf4..36b2e90778 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -1,7 +1,8 @@ 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 mirrors ; +classes.tuple namespaces vectors bit-arrays byte-arrays strings +sbufs math.functions macros sequences.private combinators +mirrors ; IN: inverse TUPLE: fail ; diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index d2348fd4b0..259173fec4 100755 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -1,8 +1,8 @@ ! 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 tuples words io -io.files splitting namespaces math compiler.units accessors ; +hashtables io.encodings.ascii generic parser classes.tuple words +io io.files splitting namespaces math compiler.units accessors ; IN: io.encodings.8-bit [ gadget? ] is? diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/extra/ui/gadgets/scrollers/scrollers.factor index 7966f4e206..99bd1be876 100755 --- a/extra/ui/gadgets/scrollers/scrollers.factor +++ b/extra/ui/gadgets/scrollers/scrollers.factor @@ -4,7 +4,7 @@ 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 -tuples ; +classes.tuple ; IN: ui.gadgets.scrollers TUPLE: scroller viewport x y follows ; diff --git a/extra/ui/gadgets/tracks/tracks-docs.factor b/extra/ui/gadgets/tracks/tracks-docs.factor index 967e8a29a1..f10996135d 100755 --- a/extra/ui/gadgets/tracks/tracks-docs.factor +++ b/extra/ui/gadgets/tracks/tracks-docs.factor @@ -1,5 +1,5 @@ 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 diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index 574b71c44d..412a61bcb5 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -2,7 +2,8 @@ ! 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 +math.vectors classes.tuple classes ui.gadgets combinators.lib +boxes calendar alarms symbols ; IN: ui.gestures diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index 9e43460aa9..06fc3c87a0 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -4,7 +4,7 @@ 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 +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 ; IN: ui.tools.interactor diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor index 45ac645392..23697bbf3f 100755 --- a/extra/ui/tools/search/search.factor +++ b/extra/ui/tools/search/search.factor @@ -4,7 +4,7 @@ USING: assocs ui.tools.interactor ui.tools.listener 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 ; diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 158a48a1c0..eaf87acace 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -5,7 +5,7 @@ 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.render math.vectors classes.tuple opengl.gl threads ; IN: ui.x11 TUPLE: x11-ui-backend ; From 9e13e61a74c150eff97c4da1ed0c9cbc3d924c3d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Mar 2008 04:07:06 -0500 Subject: [PATCH 284/886] Fix some load errors --- extra/bunny/model/model.factor | 23 +++++++++++++---------- extra/bunny/outlined/outlined.factor | 2 +- extra/combinators/cleave/cleave.factor | 2 +- extra/opengl/shaders/shaders.factor | 4 ++-- 4 files changed, 17 insertions(+), 14 deletions(-) diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 79a8a00856..2cb0df5ca1 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -64,16 +64,19 @@ TUPLE: bunny-buffers array element-array nv ni ; bunny-dlist construct-boa ; : ( model -- geom ) - [ - [ first concat ] [ second concat ] bi - append >float-array - GL_ARRAY_BUFFER swap GL_STATIC_DRAW - ] [ - third concat >c-uint-array - GL_ELEMENT_ARRAY_BUFFER swap GL_STATIC_DRAW - ] - [ 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 + ] + [ + third concat >c-uint-array + GL_ELEMENT_ARRAY_BUFFER swap GL_STATIC_DRAW + ] + [ first length 3 * ] + [ third length 3 * ] + } cleave bunny-buffers construct-boa ; GENERIC: bunny-geom ( geom -- ) GENERIC: draw-bunny ( geom draw -- ) diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 7cdfba7c79..6a2f54cceb 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -1,6 +1,6 @@ USING: arrays bunny.model bunny.cel-shaded continuations kernel math multiline opengl opengl.shaders opengl.framebuffers -opengl.gl opengl.capabilities sequences ui.gadgets ; +opengl.gl opengl.capabilities sequences ui.gadgets combinators ; IN: bunny.outlined STRING: outlined-pass1-fragment-shader-main-source diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index 9ce7a1f553..d99fe7e1d2 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -1,5 +1,5 @@ -USING: kernel sequences macros ; +USING: kernel sequences macros combinators ; IN: combinators.cleave diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor index 4ed43d393b..e352eabc10 100755 --- a/extra/opengl/shaders/shaders.factor +++ b/extra/opengl/shaders/shaders.factor @@ -1,8 +1,8 @@ ! 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 -macros arrays ; +assocs alien libc opengl math sequences combinators +combinators.lib macros arrays ; IN: opengl.shaders : with-gl-shader-source-ptr ( string quot -- ) From 47c91e379ea25f30d1b8261f0be5979d6ad0aa7e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Mar 2008 05:03:04 -0500 Subject: [PATCH 285/886] Fix predicate clobberage --- core/classes/tuple/tuple-tests.factor | 13 +++++++++++++ core/classes/tuple/tuple.factor | 5 ++--- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 2e37655f1d..9b8228155b 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -340,6 +340,19 @@ TUPLE: electronic-device ; [ f ] [ "laptop" get electronic-device? ] unit-test [ t ] [ "laptop" get computer? ] 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 diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 28dbfdb372..a452d0eeec 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -140,12 +140,11 @@ PRIVATE> [ drop f tuple-class define-class ] [ nip define-tuple-slots ] [ 2drop - class-usages [ - drop + class-usages keys [ tuple-class? ] subset [ [ define-tuple-layout ] [ define-tuple-predicate ] bi - ] assoc-each + ] each ] 3tri ; : redefine-tuple-class ( class superclass slots -- ) From 189a9323cddd7bfb26c294710b1a8efd0731762b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Mar 2008 05:03:17 -0500 Subject: [PATCH 286/886] Fix tree shaker issue --- core/parser/parser-docs.factor | 8 +++++--- core/parser/parser.factor | 6 +++--- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 4d200c17d2..cc4e2c0a42 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -333,12 +333,14 @@ HELP: CREATE { $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 } "." } diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 6bae4e95b4..6e5023f74a 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -252,13 +252,13 @@ PREDICATE: unexpected-eof < unexpected [ "Use the word " swap summary append ] keep ] { } map>assoc ; -TUPLE: no-word name ; +ERROR: 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 construct-boa swap words-named [ forward-reference? not ] subset word-restarts throw-restarts dup word-vocabulary (use+) ; From 01fd99fd71637eacc7082e5b1937d917fdd62a29 Mon Sep 17 00:00:00 2001 From: slava Date: Sat, 29 Mar 2008 05:30:25 -0500 Subject: [PATCH 287/886] Starting work on Solaris port --- vm/os-solaris-x86.32.h | 10 ++++++++++ vm/os-solaris-x86.64.h | 10 ++++++++++ vm/os-solaris.h | 2 ++ vm/platform.h | 10 +++++++++- 4 files changed, 31 insertions(+), 1 deletion(-) create mode 100644 vm/os-solaris-x86.32.h create mode 100644 vm/os-solaris-x86.64.h diff --git a/vm/os-solaris-x86.32.h b/vm/os-solaris-x86.32.h new file mode 100644 index 0000000000..1f4ec74e17 --- /dev/null +++ b/vm/os-solaris-x86.32.h @@ -0,0 +1,10 @@ +#include + +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]) diff --git a/vm/os-solaris-x86.64.h b/vm/os-solaris-x86.64.h new file mode 100644 index 0000000000..54d1866d50 --- /dev/null +++ b/vm/os-solaris-x86.64.h @@ -0,0 +1,10 @@ +#include + +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]) diff --git a/vm/os-solaris.h b/vm/os-solaris.h index 788a78090b..909cc3f4e9 100644 --- a/vm/os-solaris.h +++ b/vm/os-solaris.h @@ -1,2 +1,4 @@ #define UNKNOWN_TYPE_P(file) 1 #define DIRECTORY_P(file) 0 + +extern char **environ; diff --git a/vm/platform.h b/vm/platform.h index 7678d483d6..a8c8ba756f 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -95,8 +95,16 @@ #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 From cee0eb5be35153212da887ab09e903b9400b3101 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Mar 2008 14:25:57 -0500 Subject: [PATCH 288/886] fix secure-random-generator for windows --- extra/random/windows/windows.factor | 57 ++++++++++++++++++-------- extra/windows/advapi32/advapi32.factor | 34 +++++++++++++++ 2 files changed, 74 insertions(+), 17 deletions(-) diff --git a/extra/random/windows/windows.factor b/extra/random/windows/windows.factor index e0c564bc2c..cd69105e65 100644 --- a/extra/random/windows/windows.factor +++ b/extra/random/windows/windows.factor @@ -1,31 +1,54 @@ USING: accessors alien.c-types byte-arrays continuations -kernel windows windows.advapi32 init namespaces random ; +kernel windows windows.advapi32 init namespaces random +destructors locals ; +USE: tools.walker IN: random.windows -TUPLE: windows-crypto-context handle ; +TUPLE: windows-rng provider type ; +C: windows-rng +TUPLE: windows-crypto-context handle ; C: windows-crypto-context M: windows-crypto-context dispose ( tuple -- ) handle>> 0 CryptReleaseContext win32-error=0/f ; -TUPLE: windows-cryptographic-rng context ; +: factor-crypto-container ( -- string ) "FactorCryptoContainer" ; inline -C: windows-cryptographic-rng +:: (acquire-crypto-context) ( provider type flags -- handle ) + [let | handle [ "HCRYPTPROV" ] | + handle + factor-crypto-container + provider + type + flags + CryptAcquireContextW win32-error=0/f + handle *void* ] ; -M: windows-cryptographic-rng dispose ( tuple -- ) - context>> dispose ; +: acquire-crypto-context ( provider type -- handle ) + [ 0 (acquire-crypto-context) ] + [ drop CRYPT_NEWKEYSET (acquire-crypto-context) ] recover ; -M: windows-cryptographic-rng random-bytes* ( tuple n -- bytes ) - >r context>> r> dup - [ CryptGenRandom win32-error=0/f ] keep ; -: windows-aes-context ( -- context ) - "HCRYPTPROV" - dup f f PROV_RSA_AES CRYPT_NEWKEYSET - CryptAcquireContextW win32-error=0/f *void* - ; +: windows-crypto-context ( provider type -- context ) + acquire-crypto-context ; -! [ - ! windows-aes-context secure-random-generator set-global -! ] "random.windows" add-init-hook +M: windows-rng random-bytes* ( n tuple -- bytes ) + [ + [ provider>> ] [ type>> ] bi + windows-crypto-context + dup add-always-destructor handle>> + swap dup + [ CryptGenRandom win32-error=0/f ] keep + ] with-destructors ; + +[ + MS_DEF_PROV + PROV_RSA_FULL insecure-random-generator set-global + + ! MS_STRONG_PROV + ! PROV_RSA_FULL secure-random-generator set-global + + MS_ENH_RSA_AES_PROV + PROV_RSA_AES secure-random-generator set-global +] "random.windows" add-init-hook diff --git a/extra/windows/advapi32/advapi32.factor b/extra/windows/advapi32/advapi32.factor index 0be82551a1..28091d3d9d 100644 --- a/extra/windows/advapi32/advapi32.factor +++ b/extra/windows/advapi32/advapi32.factor @@ -21,6 +21,40 @@ LIBRARY: advapi32 : 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 From a15159af6944c1a341b581b81592cd997b2aac3b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Mar 2008 14:50:52 -0500 Subject: [PATCH 289/886] add summary on error --- extra/random/random.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/random/random.factor b/extra/random/random.factor index c1701b1c0f..1168a4dd45 100755 --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -19,6 +19,9 @@ M: object random-32* ( tuple -- r ) 4 random-bytes* le> ; ERROR: no-random-number-generator ; +M: no-random-number-generator summary + drop "Random number generator is not defined." ; + M: f random-bytes* ( n obj -- * ) no-random-number-generator ; M: f random-32* ( obj -- * ) no-random-number-generator ; From 72cedcaf477c3aa119bbf2cf8cceb5cd5c31d66f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Mar 2008 14:51:50 -0500 Subject: [PATCH 290/886] add using --- extra/random/random.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/random/random.factor b/extra/random/random.factor index 1168a4dd45..b1c57ede60 100755 --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types kernel math namespaces sequences -io.backend io.binary combinators system vocabs.loader ; +io.backend io.binary combinators system vocabs.loader +inspector ; IN: random SYMBOL: insecure-random-generator From fbdf62bb1cf45809ed64061220c7aa9569cc64d9 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 29 Mar 2008 16:18:46 -0400 Subject: [PATCH 291/886] Making [ mpg ] undo work --- extra/inverse/inverse.factor | 55 +++++++++++++++++++--------------- extra/units/units-tests.factor | 4 +-- extra/units/units.factor | 6 ++++ 3 files changed, 38 insertions(+), 27 deletions(-) diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 308bf36bf4..f4bd403b75 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -1,7 +1,8 @@ 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 mirrors ; +math.functions macros sequences.private combinators mirrors +combinators.lib ; IN: inverse TUPLE: fail ; @@ -59,38 +60,44 @@ 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 ; +: enough? ( stack quot -- ? ) + [ >r length r> 1quotation infer effect-in >= ] [ 3drop f ] + recover ; -: math-exp? ( n n word -- ? ) - { + - * / ^ } member? -rot [ number? ] both? and ; +: fold-word ( stack quot -- stack ) + 2dup enough? + [ 1quotation with-datastack ] [ >r % r> , { } ] if ; -: (fold-constants) ( quot -- ) - dup length 3 < [ % ] [ - dup first3 3dup math-exp? - [ execute , 3 ] [ 2drop , 1 ] if - tail-slice (fold-constants) - ] if ; +: fold ( quot -- folded-quot ) + [ { } swap [ fold-word ] each % ] [ ] make ; -: fold-constants ( quot -- folded ) - [ (fold-constants) ] [ ] make ; +: flattenable? ( object -- ? ) + [ [ word? ] [ primitive? not ] and? ] [ + { "inverse" "math-inverse" "pop-inverse" } + [ word-prop ] with contains? not + ] and? ; -: do-inlining ( quot -- inlined-quot ) - [ [ inline-word ] each ] [ ] make fold-constants ; +: (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 ; @@ -108,7 +115,7 @@ M: pop-inverse inverse [ unclip-slice inverse % (undo) ] if ; : [undo] ( quot -- undo ) - do-inlining reverse [ (undo) ] [ ] make ; + flatten fold reverse [ (undo) ] [ ] make ; MACRO: undo ( quot -- ) [undo] ; diff --git a/extra/units/units-tests.factor b/extra/units/units-tests.factor index 9f0e704157..9b450ed18b 100755 --- a/extra/units/units-tests.factor +++ b/extra/units/units-tests.factor @@ -15,9 +15,7 @@ IN: units.tests [ t ] [ 1 m 2 m 3 m 3array d-product 6 m^3 = ] unit-test [ t ] [ 3 m d-recip 1/3 { } { m } = ] 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 diff --git a/extra/units/units.factor b/extra/units/units.factor index 13d0a5d1cf..b92cbb659a 100755 --- a/extra/units/units.factor +++ b/extra/units/units.factor @@ -95,3 +95,9 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; : 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 From 606445f790e290fae775a00c4f5ccb257a713a0b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Mar 2008 15:31:31 -0500 Subject: [PATCH 292/886] improve png --- extra/cairo/ffi/ffi.factor | 3 +++ extra/cairo/png/png.factor | 27 ++++++++++++++++++++++++--- 2 files changed, 27 insertions(+), 3 deletions(-) diff --git a/extra/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor index 76ce27975b..c319ade93b 100644 --- a/extra/cairo/ffi/ffi.factor +++ b/extra/cairo/ffi/ffi.factor @@ -203,6 +203,9 @@ C-ENUM: 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 ; diff --git a/extra/cairo/png/png.factor b/extra/cairo/png/png.factor index eaab28e659..774a1afe8e 100755 --- a/extra/cairo/png/png.factor +++ b/extra/cairo/png/png.factor @@ -1,16 +1,34 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel accessors math ui.gadgets ui.render -opengl.gl byte-arrays namespaces opengl cairo.ffi cairo.lib ; +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 + dup zero? [ + "PNG dimension is 0" cairo-error + ] when ; + +: cairo-png-error ( n -- ) + { + { [ dup CAIRO_STATUS_NO_MEMORY = ] [ "Cairo: no memory" cairo-error ] } + { [ dup CAIRO_STATUS_FILE_NOT_FOUND = ] [ "Cairo: file not found" cairo-error ] } + { [ dup CAIRO_STATUS_READ_ERROR = ] [ "Cairo: read error" cairo-error ] } + { [ t ] [ drop ] } + } cond ; + : ( path -- png ) + normalize-pathname cairo_image_surface_create_from_png - dup [ cairo_image_surface_get_width ] - [ cairo_image_surface_get_height ] [ ] tri + 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 construct-boa ; : write-png ( png path -- ) @@ -33,6 +51,7 @@ M: png-gadget draw-gadget* ( gadget -- ) png>> [ width>> ] [ height>> GL_RGBA GL_UNSIGNED_BYTE ] + ! [ height>> GL_BGRA GL_UNSIGNED_BYTE ] [ array>> ] tri glDrawPixels ] with-translation ; @@ -42,3 +61,5 @@ M: png-gadget graft* ( gadget -- ) M: png-gadget ungraft* ( gadget -- ) png>> surface>> cairo_destroy ; + +! "resource:misc/icons/Factor_1x16.png" USE: cairo.png gadget. From 7174e8cbc4e51dddfc6b258d80e4681428952462 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Mar 2008 15:50:50 -0500 Subject: [PATCH 293/886] Fixing unit test failures --- core/parser/parser-tests.factor | 4 ++-- core/parser/parser.factor | 2 +- core/vocabs/loader/loader-tests.factor | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index a15da82718..6bd4abb7e1 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -322,7 +322,7 @@ IN: parser.tests [ "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] [ [ no-word? ] is? ] must-fail-with + ] [ [ no-word-error? ] is? ] must-fail-with [ ] [ "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" @@ -332,7 +332,7 @@ IN: parser.tests [ "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] [ [ no-word? ] is? ] must-fail-with + ] [ [ no-word-error? ] is? ] must-fail-with [ "IN: parser.tests : foo ; TUPLE: foo ;" diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 6e5023f74a..f8836217b5 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -252,7 +252,7 @@ PREDICATE: unexpected-eof < unexpected [ "Use the word " swap summary append ] keep ] { } map>assoc ; -ERROR: no-word-error name ; +TUPLE: no-word-error name ; M: no-word-error summary drop "Word not found in current vocabulary search path" ; diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index fd3b616b87..4b978932bc 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -68,7 +68,7 @@ IN: vocabs.loader.tests "resource:core/vocabs/loader/test/a/a.factor" parse-stream -] [ [ no-word? ] is? ] must-fail-with +] [ [ no-word-error? ] is? ] must-fail-with 0 "count-me" set-global From 0e6f753b2f17bc677a3c6329a0741a623298d818 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Mar 2008 16:04:46 -0500 Subject: [PATCH 294/886] Fix help --- core/classes/tuple/tuple-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index a747008fa2..7123d5c7c8 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -162,7 +162,7 @@ HELP: reshape-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" } } +{ $values { "class" tuple-class } { "superclass" class } { "newslots" "a sequence of strings" } } { $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ; HELP: removed-slots @@ -170,7 +170,7 @@ HELP: removed-slots { $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" } } +{ $values { "class" tuple-class } { "slots" "a sequence of strings" } } { $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ; HELP: tuple From 8ea195d8ce8693e1b892c65fa1864272a472caa3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 29 Mar 2008 16:08:08 -0600 Subject: [PATCH 295/886] hashtables: use cleavers in hashtables --- core/hashtables/hashtables.factor | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 7d8c6f0b5f..1fabc1aab7 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -95,11 +95,12 @@ IN: hashtables [ 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 @@ -183,10 +184,13 @@ M: hashtable assoc-like [ 3drop ] [ dupd dupd set-at swap push ] if ; inline : prune ( seq -- newseq ) - dup length over length - rot [ >r 2dup r> (prune) ] each nip ; + [ length ] + [ length ] + [ ] tri + [ >r 2dup r> (prune) ] each nip ; : all-unique? ( seq -- ? ) - dup prune [ length ] 2apply = ; + [ length ] + [ prune length ] bi = ; INSTANCE: hashtable assoc From 691d26068d850b4331ad0d7a028f076cf3242989 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sun, 30 Mar 2008 14:00:45 +1300 Subject: [PATCH 296/886] Refactor peg compiler cache Instead of a cache stored in a global variable, the compiled parser is stored in a slot in the parser delegate. --- extra/peg/peg-docs.factor | 7 ------- extra/peg/peg.factor | 28 ++++++++++------------------ 2 files changed, 10 insertions(+), 25 deletions(-) diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index 7b13e06d5a..e7bd255569 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -21,16 +21,9 @@ HELP: compile } { $description "Compile the parser to a word. The word will have stack effect ( -- result )." - "The mapping from parser to compiled word is kept in a cache. If you later change " - "the definition of a parser you'll need to clear this cache with " - { $link reset-compiled-parsers } " before using " { $link compile } " on that parser again." } { $see-also parse } ; -HELP: reset-compiled-parsers -{ $description - "Reset the cache mapping parsers to compiled words." } ; - HELP: token { $values { "string" "a string" } diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index c9de46aa86..247a64eac2 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -10,6 +10,10 @@ USE: prettyprint TUPLE: parse-result remaining ast ; +TUPLE: parser id compiled ; +M: parser equal? [ id>> ] 2apply = ; +C: parser + SYMBOL: ignore : ( remaining ast -- parse-result ) @@ -194,14 +198,6 @@ C: peg-head ] H{ } make-assoc swap bind ; inline -: compiled-parsers ( -- cache ) - \ compiled-parsers get-global [ H{ } clone dup \ compiled-parsers set-global ] unless* ; - -: reset-compiled-parsers ( -- ) - H{ } clone \ compiled-parsers set-global ; - -reset-compiled-parsers - GENERIC: (compile) ( parser -- quot ) @@ -226,11 +222,11 @@ GENERIC: (compile) ( parser -- quot ) #! 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 id>> compiled-parsers [ - drop dup gensym swap 2dup id>> compiled-parsers set-at - 2dup parser-body define - dupd "peg" set-word-prop - ] cache nip ; + dup compiled>> [ + nip + ] [ + gensym tuck >>compiled 2dup parser-body define dupd "peg" set-word-prop + ] if* ; : compile ( parser -- word ) [ compiled-parser ] with-compilation-unit ; @@ -253,10 +249,6 @@ SYMBOL: id 1 id set-global 0 ] if* ; -TUPLE: parser id ; -M: parser equal? [ id>> ] 2apply = ; -C: parser - : delegates ( -- cache ) \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ; @@ -269,7 +261,7 @@ reset-delegates #! Set the delegate for the parser. Equivalent parsers #! get a delegate with the same id. dup clone delegates [ - drop next-id + drop next-id f ] cache over set-delegate ; TUPLE: token-parser symbol ; From 9df74f9b6fa31cfb0f9a8bd9390b8ad01be4f9ae Mon Sep 17 00:00:00 2001 From: erg Date: Sat, 29 Mar 2008 20:12:22 -0500 Subject: [PATCH 297/886] help lint fixes for random --- extra/random/random-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/random/random-docs.factor b/extra/random/random-docs.factor index 905f81b53d..a8a214dcc7 100644 --- a/extra/random/random-docs.factor +++ b/extra/random/random-docs.factor @@ -17,7 +17,7 @@ HELP: random-32* { $description "Generates a random 32-bit unsigned integer." } ; HELP: random-bytes* -{ $values { "n" "an integer" } { "tuple" "a random number generator" } { "bytes" "a sequence of 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 @@ -26,7 +26,7 @@ HELP: random { $notes "Since integers are sequences, passing an integer " { $snippet "n" } " yields a random integer in the interval " { $snippet "[0,n)" } "." } ; HELP: random-bytes -{ $values { "n" "an integer" } { "bytes" "a random integer" } } +{ $values { "n" "an integer" } { "byte-array" "a random integer" } } { $description "Outputs an integer with n bytes worth of bits." } ; HELP: random-bits From db7939d68cc3804dfde59dda9ef8960ef8a94199 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Mar 2008 20:28:07 -0500 Subject: [PATCH 298/886] Cleanup --- core/hashtables/hashtables.factor | 23 +++++++++-------------- 1 file changed, 9 insertions(+), 14 deletions(-) diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 1fabc1aab7..4527d2044d 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -18,14 +18,9 @@ IN: hashtables : (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 @@ -89,7 +84,8 @@ IN: hashtables ] 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 ; @@ -99,8 +95,7 @@ IN: hashtables [ hash-array array-capacity ] bi > ; : hash-stale? ( hash -- ? ) - [ hash-deleted 10 fixnum*fast ] - [ hash-count ] bi fixnum> ; + [ hash-deleted 10 fixnum*fast ] [ hash-count ] bi fixnum> ; : grow-hash ( hash -- ) [ dup hash-array swap assoc-size 1+ ] keep @@ -185,12 +180,12 @@ M: hashtable assoc-like : prune ( seq -- newseq ) [ length ] - [ length ] - [ ] tri + [ length ] + [ ] tri [ >r 2dup r> (prune) ] each nip ; : all-unique? ( seq -- ? ) - [ length ] + [ length ] [ prune length ] bi = ; INSTANCE: hashtable assoc From c22af5c7a6fe94e6550debfd0593425f271011b7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Mar 2008 20:36:58 -0500 Subject: [PATCH 299/886] Rename 2apply to bi@ --- core/alien/alien.factor | 2 +- core/assocs/assocs.factor | 2 +- core/bit-arrays/bit-arrays-tests.factor | 2 +- core/bootstrap/stage2.factor | 2 +- core/classes/algebra/algebra.factor | 2 +- core/classes/mixin/mixin.factor | 4 ++-- core/compiler/tests/curry.factor | 2 +- core/compiler/tests/templates.factor | 4 ++-- core/cpu/arm/architecture/architecture.factor | 6 +++--- core/cpu/ppc/allot/allot.factor | 2 +- core/cpu/ppc/architecture/architecture.factor | 8 ++++---- core/cpu/x86/allot/allot.factor | 2 +- core/cpu/x86/architecture/architecture.factor | 8 ++++---- core/debugger/debugger.factor | 2 +- core/dlists/dlists-tests.factor | 2 +- core/effects/effects.factor | 4 ++-- core/generator/registers/registers.factor | 14 ++++++------- core/hashtables/hashtables.factor | 2 +- core/heaps/heaps-tests.factor | 4 ++-- core/inference/class/class.factor | 4 ++-- core/inference/inference-tests.factor | 2 +- core/io/files/files-tests.factor | 2 +- core/kernel/kernel-docs.factor | 6 +++--- core/kernel/kernel.factor | 3 --- core/math/intervals/intervals-tests.factor | 6 +++--- core/math/intervals/intervals.factor | 20 +++++++++---------- core/optimizer/def-use/def-use-tests.factor | 2 +- core/optimizer/math/math.factor | 4 ++-- core/parser/parser.factor | 2 +- core/prettyprint/prettyprint.factor | 2 +- core/quotations/quotations.factor | 2 +- core/sequences/sequences-tests.factor | 6 +++--- core/sequences/sequences.factor | 12 +++++------ core/sorting/sorting.factor | 2 +- core/splitting/splitting.factor | 2 +- core/vectors/vectors-tests.factor | 2 +- core/vocabs/vocabs.factor | 2 +- extra/benchmark/raytracer/raytracer.factor | 4 ++-- .../reverse-complement-tests.factor | 2 +- .../spectral-norm/spectral-norm.factor | 2 +- extra/bitfields/bitfields.factor | 2 +- extra/boids/boids.factor | 2 +- extra/builder/benchmark/benchmark.factor | 4 ++-- extra/builder/util/util.factor | 2 +- extra/calendar/calendar.factor | 8 ++++---- extra/calendar/format/format.factor | 2 +- extra/cocoa/dialogs/dialogs.factor | 2 +- extra/crypto/rsa/rsa.factor | 2 +- extra/crypto/sha1/sha1.factor | 2 +- extra/documents/documents.factor | 6 +++--- extra/faq/faq.factor | 2 +- extra/fry/fry-docs.factor | 2 +- extra/help/lint/lint.factor | 2 +- extra/http/http.factor | 2 +- extra/icfp/2006/2006.factor | 4 ++-- extra/inverse/inverse.factor | 4 ++-- extra/io/encodings/utf16/utf16.factor | 2 +- extra/io/nonblocking/nonblocking.factor | 2 +- extra/io/sockets/impl/impl.factor | 4 ++-- extra/io/unix/files/files.factor | 4 ++-- extra/io/windows/ce/backend/backend.factor | 2 +- extra/io/windows/windows.factor | 4 ++-- extra/jamshred/tunnel/tunnel.factor | 2 +- extra/koszul/koszul.factor | 10 +++++----- extra/lazy-lists/lazy-lists.factor | 2 +- extra/levenshtein/levenshtein.factor | 4 ++-- extra/lint/lint.factor | 4 ++-- extra/match/match.factor | 4 ++-- extra/math/complex/complex.factor | 6 +++--- extra/math/functions/functions.factor | 4 ++-- extra/math/polynomials/polynomials.factor | 16 +++++++-------- extra/math/quaternions/quaternions.factor | 2 +- extra/math/ratios/ratios.factor | 4 ++-- extra/math/statistics/statistics.factor | 4 ++-- extra/maze/maze.factor | 2 +- extra/money/money.factor | 4 ++-- extra/multi-methods/multi-methods.factor | 2 +- extra/opengl/demo-support/demo-support.factor | 2 +- extra/opengl/opengl.factor | 6 +++--- .../parser-combinators.factor | 4 ++-- extra/peg/parsers/parsers.factor | 2 +- extra/peg/peg.factor | 2 +- extra/project-euler/009/009.factor | 2 +- extra/project-euler/014/014.factor | 2 +- extra/project-euler/026/026.factor | 2 +- extra/project-euler/027/027.factor | 2 +- extra/project-euler/033/033.factor | 4 ++-- extra/project-euler/044/044.factor | 2 +- extra/project-euler/079/079.factor | 2 +- extra/random-tester/random/random.factor | 2 +- extra/regexp/regexp.factor | 2 +- extra/regexp2/regexp2.factor | 2 +- extra/reports/noise/noise.factor | 2 +- extra/roman/roman.factor | 4 ++-- extra/semantic-db/semantic-db-tests.factor | 2 +- extra/serialize/serialize.factor | 2 +- extra/shufflers/shufflers.factor | 2 +- extra/sudoku/sudoku.factor | 2 +- extra/tar/tar.factor | 2 +- extra/tools/completion/completion.factor | 4 ++-- extra/tools/deploy/shaker/strip-cocoa.factor | 2 +- extra/ui/gadgets/borders/borders.factor | 2 +- extra/ui/gadgets/editors/editors.factor | 2 +- extra/ui/gadgets/gadgets.factor | 2 +- extra/ui/gadgets/grids/grids-tests.factor | 4 ++-- extra/ui/gadgets/scrollers/scrollers.factor | 2 +- extra/unicode/breaks/breaks.factor | 4 ++-- extra/unicode/case/case.factor | 2 +- extra/unicode/normalize/normalize.factor | 2 +- extra/units/units.factor | 14 ++++++------- extra/xmode/catalog/catalog.factor | 2 +- 111 files changed, 196 insertions(+), 199 deletions(-) diff --git a/core/alien/alien.factor b/core/alien/alien.factor index d0adec1fcf..cfa9fb2e16 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -39,7 +39,7 @@ M: alien equal? 2dup [ expired? ] either? [ [ expired? ] both? ] [ - [ alien-address ] 2apply = + [ alien-address ] bi@ = ] if ] [ 2drop f diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 196ec614b7..b911faf672 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -115,7 +115,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) swap [ swapd set-at ] curry assoc-each ; : union ( assoc1 assoc2 -- union ) - 2dup [ assoc-size ] 2apply + pick new-assoc + 2dup [ assoc-size ] bi@ + pick new-assoc [ rot update ] keep [ swap update ] keep ; : diff ( assoc1 assoc2 -- diff ) diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor index 5774b86e45..e28c16c3c2 100755 --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -21,7 +21,7 @@ IN: bit-arrays.tests { t f t } { f t f } ] [ { t f t } >bit-array dup clone dup [ not ] change-each - [ >array ] 2apply + [ >array ] bi@ ] unit-test [ diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index f472e0158f..bbb2e44843 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -23,7 +23,7 @@ SYMBOL: bootstrap-time : load-components ( -- ) "exclude" "include" - [ get-global " " split [ empty? not ] subset ] 2apply + [ get-global " " split [ empty? not ] subset ] bi@ seq-diff [ "bootstrap." prepend require ] each ; diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index e2206213a6..2945bd2546 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -67,7 +67,7 @@ C: anonymous-complement members>> [ class< ] with all? ; : anonymous-complement< ( first second -- ? ) - [ class>> ] 2apply swap class< ; + [ class>> ] bi@ swap class< ; : (class<) ( first second -- -1/0/1 ) { diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 85a6fb241d..eb6b3bd6e2 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -47,8 +47,8 @@ TUPLE: mixin-instance loc class mixin ; M: mixin-instance equal? { { [ over mixin-instance? not ] [ f ] } - { [ 2dup [ mixin-instance-class ] 2apply = not ] [ f ] } - { [ 2dup [ mixin-instance-mixin ] 2apply = not ] [ f ] } + { [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] } + { [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] } { [ t ] [ t ] } } cond 2nip ; diff --git a/core/compiler/tests/curry.factor b/core/compiler/tests/curry.factor index d2e7115f8f..61d20fd8ab 100755 --- a/core/compiler/tests/curry.factor +++ b/core/compiler/tests/curry.factor @@ -10,7 +10,7 @@ IN: compiler.tests [ 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 diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 8a33d57fe7..081a8fd47c 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -72,13 +72,13 @@ 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 [ 1 ] [ diff --git a/core/cpu/arm/architecture/architecture.factor b/core/cpu/arm/architecture/architecture.factor index 8742a693cb..563dd10bc4 100755 --- a/core/cpu/arm/architecture/architecture.factor +++ b/core/cpu/arm/architecture/architecture.factor @@ -63,7 +63,7 @@ M: arm-backend load-indirect ( obj reg -- ) M: immediate load-literal over v>operand small-enough? [ - [ v>operand ] 2apply swap MOV + [ v>operand ] bi@ swap MOV ] [ v>operand load-indirect ] if ; @@ -322,10 +322,10 @@ M: arm-backend fp-shadows-int? ( -- ? ) f ; ! 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 ; diff --git a/core/cpu/ppc/allot/allot.factor b/core/cpu/ppc/allot/allot.factor index df0a08a86d..6c37fce4f1 100755 --- a/core/cpu/ppc/allot/allot.factor +++ b/core/cpu/ppc/allot/allot.factor @@ -33,7 +33,7 @@ IN: cpu.ppc.allot f fresh-object ; M: ppc-backend %box-float ( dst src -- ) - [ v>operand ] 2apply %allot-float 12 MR ; + [ v>operand ] bi@ %allot-float 12 MR ; : %allot-bignum ( #digits -- ) #! 1 cell header, 1 cell length, 1 cell sign, + digits diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 1daf3ac622..903ac32df9 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -71,7 +71,7 @@ M: ds-loc loc>operand ds-loc-n cells neg ds-reg swap ; 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 -- ) [ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep @@ -138,7 +138,7 @@ M: ppc-backend %replace >r v>operand r> loc>operand STW ; M: ppc-backend %unbox-float ( dst src -- ) - [ v>operand ] 2apply float-offset LFD ; + [ v>operand ] bi@ float-offset LFD ; M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ; @@ -291,10 +291,10 @@ M: ppc-backend %unbox-small-struct ! Alien intrinsics M: ppc-backend %unbox-byte-array ( dst src -- ) - [ v>operand ] 2apply byte-array-offset ADDI ; + [ v>operand ] bi@ byte-array-offset ADDI ; M: ppc-backend %unbox-alien ( dst src -- ) - [ v>operand ] 2apply alien-offset LWZ ; + [ v>operand ] bi@ alien-offset LWZ ; M: ppc-backend %unbox-f ( dst src -- ) drop 0 swap v>operand LI ; diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor index f837a92504..5519a9a8d5 100755 --- a/core/cpu/x86/allot/allot.factor +++ b/core/cpu/x86/allot/allot.factor @@ -101,6 +101,6 @@ M: x86-backend %box-alien ( dst src -- ) ] %allot "end" get JMP "f" resolve-label - f [ v>operand ] 2apply MOV + f [ v>operand ] bi@ MOV "end" resolve-label ] with-scope ; diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index f993639c05..31fa4c8e4b 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -109,9 +109,9 @@ M: x86-backend %dispatch-label ( word -- ) 0 cell, rc-absolute-cell rel-word ; M: x86-backend %unbox-float ( dst src -- ) - [ v>operand ] 2apply float-offset [+] MOVSD ; + [ v>operand ] bi@ float-offset [+] MOVSD ; -M: x86-backend %peek [ v>operand ] 2apply MOV ; +M: x86-backend %peek [ v>operand ] bi@ MOV ; M: x86-backend %replace swap %peek ; @@ -162,10 +162,10 @@ M: x86-backend %return ( -- ) 0 %unwind ; ! Alien intrinsics M: x86-backend %unbox-byte-array ( dst src -- ) - [ v>operand ] 2apply byte-array-offset [+] LEA ; + [ v>operand ] bi@ byte-array-offset [+] LEA ; M: x86-backend %unbox-alien ( dst src -- ) - [ v>operand ] 2apply alien-offset [+] MOV ; + [ v>operand ] bi@ alien-offset [+] MOV ; M: x86-backend %unbox-f ( dst src -- ) drop v>operand 0 MOV ; diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index a7937cdb9d..033ae0680c 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -82,7 +82,7 @@ ERROR: assert got expect ; : depth ( -- n ) datastack length ; : trim-datastacks ( seq1 seq2 -- seq1' seq2' ) - 2dup [ length ] 2apply min tuck tail >r tail r> ; + 2dup [ length ] bi@ min tuck tail >r tail r> ; ERROR: relative-underflow stack ; diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor index 2bc0e6a3fb..28db6e1cbd 100755 --- a/core/dlists/dlists-tests.factor +++ b/core/dlists/dlists-tests.factor @@ -63,7 +63,7 @@ IN: dlists.tests [ 0 ] [ 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 ; diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 23e8daf122..aed4a64c6c 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -18,8 +18,8 @@ TUPLE: effect in out terminated? ; { [ dup not ] [ t ] } { [ over effect-terminated? ] [ t ] } { [ dup effect-terminated? ] [ f ] } - { [ 2dup [ effect-in length ] 2apply > ] [ f ] } - { [ 2dup [ effect-height ] 2apply = not ] [ f ] } + { [ 2dup [ effect-in length ] bi@ > ] [ f ] } + { [ 2dup [ effect-height ] bi@ = not ] [ f ] } { [ t ] [ t ] } } cond 2nip ; diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index e03923e860..aac1b2cdc6 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -79,7 +79,7 @@ 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 ; @@ -89,7 +89,7 @@ TUPLE: rs-loc n class ; 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 ; @@ -206,7 +206,7 @@ INSTANCE: constant value %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 ] } @@ -318,7 +318,7 @@ M: phantom-stack cut-phantom : 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 ; @@ -442,7 +442,7 @@ M: loc lazy-store : 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 <= ; + T{ int-regs } free-vregs [ length ] bi@ <= ; : finalize-locs ( -- ) #! Perform any deferred stack shuffling. @@ -488,7 +488,7 @@ M: loc lazy-store : phantom&spec ( phantom spec -- phantom' spec' ) [ length f pad-left ] keep - [ ] 2apply ; inline + [ ] bi@ ; inline : phantom&spec-agree? ( phantom spec quot -- ? ) >r phantom&spec r> 2all? ; inline @@ -520,7 +520,7 @@ M: loc lazy-store swap lazy-load ; : output-vregs ( -- seq seq ) - +output+ +clobber+ [ get [ get ] map ] 2apply ; + +output+ +clobber+ [ get [ get ] map ] bi@ ; : clash? ( seq -- ? ) phantoms append [ diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 4527d2044d..5ac49ffa2f 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -156,7 +156,7 @@ M: hashtable clone M: hashtable equal? over hashtable? [ - 2dup [ assoc-size ] 2apply number= + 2dup [ assoc-size ] bi@ number= [ assoc= ] [ 2drop f ] if ] [ 2drop f ] if ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index 0b3123c87b..77560c7444 100755 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -66,8 +66,8 @@ IN: heaps.tests dup heap-data clone swap ] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times heap-data - [ [ entry-key ] map ] 2apply - [ natural-sort ] 2apply ; + [ [ entry-key ] map ] bi@ + [ natural-sort ] bi@ ; 11 [ [ t ] swap [ 2^ delete-test sequence= ] curry unit-test diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 7764fd4fd1..ed36ca4890 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -26,8 +26,8 @@ C: literal-constraint M: literal-constraint equal? over literal-constraint? [ 2dup - [ literal-constraint-literal ] 2apply eql? >r - [ literal-constraint-value ] 2apply = r> and + [ literal-constraint-literal ] bi@ eql? >r + [ literal-constraint-value ] bi@ = r> and ] [ 2drop f ] if ; diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 1cc1548a3d..84014512aa 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -224,7 +224,7 @@ DEFER: do-crap* 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 diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index b78f7667a6..9920d8d25c 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -117,7 +117,7 @@ io.encodings.utf8 ; [ ] [ "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 diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 0babb14fa7..457313724c 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -60,8 +60,8 @@ $nl { $subsection keep } { $subsection 2keep } { $subsection 3keep } -{ $subsection 2apply } -"A pair of utility words built from " { $link 2apply } ":" +{ $subsection bi@ } +"A pair of utility words built from " { $link bi@ } ":" { $subsection both? } { $subsection either? } "A looping combinator:" @@ -376,7 +376,7 @@ HELP: 3keep { $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 +HELP: bi@ { $values { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } { "x" object } { "y" object } } { $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } "." } ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index cbabeb6bfa..e2e0c0171a 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -199,6 +199,3 @@ GENERIC: construct-boa ( ... class -- tuple ) : do-primitive ( number -- ) "Improper primitive call" throw ; PRIVATE> - -! Deprecated -: 2apply bi@ ; inline diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index 5a3fe777b6..f6317e7475 100755 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -169,7 +169,7 @@ IN: math.intervals.tests : 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) ] } @@ -197,7 +197,7 @@ IN: math.intervals.tests 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 ; @@ -214,7 +214,7 @@ IN: math.intervals.tests : 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 ] [ diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index d1c458065f..cc51060f63 100755 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -67,7 +67,7 @@ C: interval : (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 ) @@ -108,7 +108,7 @@ C: interval : 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 @@ -118,7 +118,7 @@ C: 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 ; @@ -131,17 +131,17 @@ C: interval : 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 @@ -163,7 +163,7 @@ C: interval [ 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? @@ -186,13 +186,13 @@ SYMBOL: incomparable : 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< ; diff --git a/core/optimizer/def-use/def-use-tests.factor b/core/optimizer/def-use/def-use-tests.factor index d5e8e2d75d..f22cce9fa8 100755 --- a/core/optimizer/def-use/def-use-tests.factor +++ b/core/optimizer/def-use/def-use-tests.factor @@ -99,7 +99,7 @@ namespaces assocs kernel sequences math tools.test words ; ] unit-test : regression-2 ( x y -- x.y ) - [ p1 ] 2apply [ + [ p1 ] bi@ [ [ rot [ 2swap [ swapd * -rot p2 +@ ] 2keep ] diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 349cf88f17..abe48ec272 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -113,7 +113,7 @@ generic.standard system ; : 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 [ @@ -147,7 +147,7 @@ generic.standard system ; ] 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 [ diff --git a/core/parser/parser.factor b/core/parser/parser.factor index f8836217b5..36e5decd05 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -475,7 +475,7 @@ SYMBOL: interactive-vocabs : removed-definitions ( -- definitions ) new-definitions old-definitions - [ get first2 union ] 2apply diff ; + [ get first2 union ] bi@ diff ; : smudged-usage ( -- usages referenced removed ) removed-definitions filter-moved keys [ diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 6c557d873d..d294f95be6 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -114,7 +114,7 @@ SYMBOL: -> : remove-breakpoints ( quot pos -- quot' ) over quotation? [ - 1+ cut [ (remove-breakpoints) ] 2apply + 1+ cut [ (remove-breakpoints) ] bi@ [ -> ] swap 3append ] [ drop diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 693e337959..c0f15a9388 100755 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -12,7 +12,7 @@ M: curry call dup 3 slot swap 4 slot 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 ; diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index c545a9baee..3a30824084 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -169,13 +169,13 @@ 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" ] 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 diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 111cf74ea2..1f2a6c5501 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -300,9 +300,9 @@ M: immutable-sequence clone-like like ; : 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 (2each) each-integer ; inline : 2reverse-each ( seq1 seq2 quot -- ) - >r [ ] 2apply r> 2each ; inline + >r [ ] bi@ r> 2each ; inline : 2reduce ( seq1 seq2 identity quot -- result ) >r -rot r> 2each ; inline @@ -460,7 +460,7 @@ M: sequence <=> [ -rot 2nth-unsafe <=> ] [ [ length ] compare ] if* ; : sequence= ( seq1 seq2 -- ? ) - 2dup [ length ] 2apply number= + 2dup [ length ] bi@ number= [ mismatch not ] [ 2drop f ] if ; inline : move ( to from seq -- ) @@ -620,12 +620,12 @@ M: sequence <=> [ 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 diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index ab2ce21010..5f81b17187 100755 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -32,7 +32,7 @@ DEFER: sort ] if ; inline : merge ( sorted1 sorted2 quot -- result ) - >r [ [ ] 2apply ] 2keep r> + >r [ [ ] bi@ ] 2keep r> rot length rot length + [ (merge) ] keep underlying ; inline diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 419a30dda4..9be1d5fc64 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -56,7 +56,7 @@ INSTANCE: groups sequence ] if ; : last-split1 ( seq subseq -- before after ) - [ ] 2apply split1 [ reverse ] 2apply + [ ] bi@ split1 [ reverse ] bi@ dup [ swap ] when ; : (split) ( separators n seq -- ) diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index d990f5f31c..18aa0f3fa7 100755 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -77,7 +77,7 @@ IN: vectors.tests [ f ] [ V{ 1 2 3 4 } dup clone - [ underlying ] 2apply eq? + [ underlying ] bi@ eq? ] unit-test [ 0 ] [ diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index f111b5bc74..886417b715 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -94,7 +94,7 @@ TUPLE: vocab-link name ; M: vocab-link equal? over vocab-link? - [ [ vocab-link-name ] 2apply = ] [ 2drop f ] if ; + [ [ vocab-link-name ] bi@ = ] [ 2drop f ] if ; M: vocab-link hashcode* vocab-link-name hashcode* ; diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index dbd1f5131b..3ec8cb4245 100755 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -133,7 +133,7 @@ DEFER: create ( level c r -- scene ) pick 1 = [ 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 ; @@ -150,7 +150,7 @@ DEFER: create ( level c r -- scene ) : pixel-grid ( -- grid ) size reverse [ size [ - [ size 0.5 * - ] 2apply swap size + [ size 0.5 * - ] bi@ swap size 3float-array ] with map ] map ; diff --git a/extra/benchmark/reverse-complement/reverse-complement-tests.factor b/extra/benchmark/reverse-complement/reverse-complement-tests.factor index c8d4714802..c66de87cb5 100755 --- a/extra/benchmark/reverse-complement/reverse-complement-tests.factor +++ b/extra/benchmark/reverse-complement/reverse-complement-tests.factor @@ -5,7 +5,7 @@ io.files kernel ; [ "c071aa7e007a9770b2fb4304f55a17e5" ] [ "extra/benchmark/reverse-complement/reverse-complement-test-in.txt" "extra/benchmark/reverse-complement/reverse-complement-test-out.txt" - [ resource-path ] 2apply + [ resource-path ] bi@ reverse-complement "extra/benchmark/reverse-complement/reverse-complement-test-out.txt" diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor index 42bae7d0d1..7eddeefc1b 100644 --- a/extra/benchmark/spectral-norm/spectral-norm.factor +++ b/extra/benchmark/spectral-norm/spectral-norm.factor @@ -7,7 +7,7 @@ IN: benchmark.spectral-norm : fast-truncate >fixnum >float ; inline : eval-A ( i j -- n ) - [ >float ] 2apply + [ >float ] bi@ dupd + dup 1+ * 2 /f fast-truncate + 1+ recip ; inline diff --git a/extra/bitfields/bitfields.factor b/extra/bitfields/bitfields.factor index 175f66f4a6..114809377b 100644 --- a/extra/bitfields/bitfields.factor +++ b/extra/bitfields/bitfields.factor @@ -63,7 +63,7 @@ M: check< summary drop "Number exceeds upper bound" ; [ 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 ) [ diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index efa7216699..4ea20629c1 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -80,7 +80,7 @@ VAR: separation-radius ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: 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 ; diff --git a/extra/builder/benchmark/benchmark.factor b/extra/builder/benchmark/benchmark.factor index 2f38462976..9e5e932831 100644 --- a/extra/builder/benchmark/benchmark.factor +++ b/extra/builder/benchmark/benchmark.factor @@ -19,11 +19,11 @@ IN: builder.benchmark 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 ; diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index 55ff38d408..92b9af41ef 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -88,7 +88,7 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: longer? ( seq seq -- ? ) [ length ] 2apply > ; +: longer? ( seq seq -- ? ) [ length ] bi@ > ; : maybe-tail* ( seq n -- seq ) 2dup longer? diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 0a808f53bd..6c29c0d1ac 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -185,7 +185,7 @@ M: number +second ( timestamp n -- timestamp ) [ month>> +month ] keep [ year>> +year ] keep ; inline -: +slots [ 2apply + ] curry 2keep ; inline +: +slots [ bi@ + ] curry 2keep ; inline PRIVATE> @@ -244,9 +244,9 @@ 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 - + ; + [ >gmt ] bi@ + [ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep + [ >time< >r >r 3600 * r> 60 * r> + + ] bi@ - + ; M: timestamp time- #! Exact calendar-time difference diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index b0bd7c464f..26ed873fd3 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -182,7 +182,7 @@ M: timestamp year. ( timestamp -- ) [ [ month>> month-abbreviations nth write ] keep bl [ day>> number>string 2 32 pad-left write ] keep bl - dup now [ year>> ] 2apply = [ + dup now [ year>> ] bi@ = [ [ hour>> write-00 ] keep ":" write minute>> write-00 ] [ diff --git a/extra/cocoa/dialogs/dialogs.factor b/extra/cocoa/dialogs/dialogs.factor index ea77c496a2..606526a240 100644 --- a/extra/cocoa/dialogs/dialogs.factor +++ b/extra/cocoa/dialogs/dialogs.factor @@ -26,7 +26,7 @@ IN: cocoa.dialogs [ -> filenames CF>string-array ] [ drop f ] if ; : split-path ( path -- dir file ) - "/" last-split1 [ ] 2apply ; + "/" last-split1 [ ] bi@ ; : save-panel ( path -- paths ) dup diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor index ffb2a64b76..ccf17da4e8 100644 --- a/extra/crypto/rsa/rsa.factor +++ b/extra/crypto/rsa/rsa.factor @@ -24,7 +24,7 @@ C: rsa : 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 ] [ diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index af3671e7d9..8f3d3e6ecc 100755 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -124,5 +124,5 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; : byte-array>sha1-interleave ( string -- seq ) [ zero? ] left-trim dup length odd? [ 1 tail ] when - seq>2seq [ byte-array>sha1 ] 2apply + seq>2seq [ byte-array>sha1 ] bi@ swap 2seq>seq ; diff --git a/extra/documents/documents.factor b/extra/documents/documents.factor index 60ae592d4c..14f0dc41ac 100755 --- a/extra/documents/documents.factor +++ b/extra/documents/documents.factor @@ -12,7 +12,7 @@ IN: documents : =line ( n loc -- newloc ) second 2array ; -: lines-equal? ( loc1 loc2 -- ? ) [ first ] 2apply number= ; +: lines-equal? ( loc1 loc2 -- ? ) [ first ] bi@ number= ; TUPLE: document locs ; @@ -46,7 +46,7 @@ TUPLE: document locs ; 2over = [ 3drop ] [ - >r [ first ] 2apply 1+ dup r> each + >r [ first ] bi@ 1+ dup r> each ] if ; inline : start/end-on-line ( from to line# -- n1 n2 ) @@ -85,7 +85,7 @@ TUPLE: document locs ; : (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 -- ) diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor index d7624466f7..c6d9cd04d2 100644 --- a/extra/faq/faq.factor +++ b/extra/faq/faq.factor @@ -91,7 +91,7 @@ C: 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" [ diff --git a/extra/fry/fry-docs.factor b/extra/fry/fry-docs.factor index 739e7d012c..84d02d529d 100755 --- a/extra/fry/fry-docs.factor +++ b/extra/fry/fry-docs.factor @@ -69,7 +69,7 @@ $nl { { $link curry } { $snippet ": curry '[ , @ ] ;" } } { { $link with } { $snippet ": with swapd '[ , _ @ ] ;" } } { { $link compose } { $snippet ": compose '[ @ @ ] ;" } } - { { $link 2apply } { $snippet ": 2apply tuck '[ , @ , @ ] call ;" } } + { { $link bi@ } { $snippet ": bi@ tuck '[ , @ , @ ] call ;" } } } ; ARTICLE: "fry.philosophy" "Fried quotation philosophy" diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index b65e44fda4..01e08473c6 100755 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -59,7 +59,7 @@ IN: help.lint : 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 -- ? ) diff --git a/extra/http/http.factor b/extra/http/http.factor index 69c0ba2c9f..6ff4829b48 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -106,7 +106,7 @@ IN: http : query>assoc ( query -- assoc ) dup [ "&" split [ - "=" split1 [ dup [ url-decode ] when ] 2apply + "=" split1 [ dup [ url-decode ] when ] bi@ ] H{ } map>assoc ] when ; diff --git a/extra/icfp/2006/2006.factor b/extra/icfp/2006/2006.factor index 1740e8a523..e88301c7f8 100755 --- a/extra/icfp/2006/2006.factor +++ b/extra/icfp/2006/2006.factor @@ -51,14 +51,14 @@ SYMBOL: open-arrays : 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 ; diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index d524180471..1b7badd94a 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -151,10 +151,10 @@ 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 diff --git a/extra/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor index e8ca04af35..fbc296e57c 100755 --- a/extra/io/encodings/utf16/utf16.factor +++ b/extra/io/encodings/utf16/utf16.factor @@ -78,7 +78,7 @@ M: utf16le decode-char swap BIN: 11111111 bitand ; : stream-write2 ( stream char1 char2 -- ) - rot [ stream-write1 ] curry 2apply ; + rot [ stream-write1 ] curry bi@ ; : char>utf16be ( stream char -- ) dup HEX: FFFF > [ diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index b345a98e88..85319ad8ef 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -161,5 +161,5 @@ TUPLE: datagram-port addr packet packet-addr ; : check-datagram-send ( packet addrspec port -- ) dup check-datagram-port - datagram-port-addr [ class ] 2apply assert= + datagram-port-addr [ class ] bi@ assert= class byte-array assert= ; diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor index 77e8e098b1..8480fcd856 100755 --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -64,8 +64,8 @@ M: inet6 inet-ntop ( data addrspec -- str ) M: inet6 inet-pton ( str addrspec -- data ) drop "::" split1 - [ [ ":" split [ hex> dup 0 ? ] map ] [ f ] if* ] 2apply - 2dup [ length ] 2apply + 8 swap - 0 swap 3append + [ [ ":" split [ hex> dup 0 ? ] map ] [ f ] if* ] bi@ + 2dup [ length ] bi@ + 8 swap - 0 swap 3append [ 2 >be ] map concat >byte-array ; M: inet6 address-size drop 16 ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 3b493d2fe4..b0b0ba456a 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -49,7 +49,7 @@ M: unix-io touch-file ( path -- ) close ; M: unix-io move-file ( from to -- ) - [ normalize-pathname ] 2apply rename io-error ; + [ normalize-pathname ] bi@ rename io-error ; M: unix-io delete-file ( path -- ) normalize-pathname unlink io-error ; @@ -69,7 +69,7 @@ M: unix-io delete-directory ( path -- ) ] with-disposal ; M: unix-io copy-file ( from to -- ) - [ normalize-pathname ] 2apply + [ normalize-pathname ] bi@ [ (copy-file) ] [ swap file-info file-info-permissions chmod io-error ] 2bi ; diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index f51521dfcc..152e76a6c7 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -46,5 +46,5 @@ M: windows-ce-io (init-stdio) ( -- ) 1 _getstdfilex _fileno 2 _getstdfilex _fileno ] if [ f ] 3apply - rot -rot [ ] 2apply + rot -rot [ ] bi@ ] with-variable ; diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 64c4684e15..27917cedfa 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -135,14 +135,14 @@ M: windows-io (file-appender) ( path -- stream ) open-append ; M: windows-io move-file ( from to -- ) - [ normalize-pathname ] 2apply MoveFile win32-error=0/f ; + [ normalize-pathname ] bi@ MoveFile win32-error=0/f ; M: windows-io delete-file ( path -- ) normalize-pathname DeleteFile win32-error=0/f ; M: windows-io copy-file ( from to -- ) dup parent-directory make-directories - [ normalize-pathname ] 2apply 0 CopyFile win32-error=0/f ; + [ normalize-pathname ] bi@ 0 CopyFile win32-error=0/f ; M: windows-io make-directory ( path -- ) normalize-pathname diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 61fef7959c..7be406d37a 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -72,7 +72,7 @@ TUPLE: segment number color radius ; : 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 ; + [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep ; : nearer-segment ( segment segment oint -- segment ) #! return whichever of the two segments is nearer to the oint diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index 71cbb1d951..f286690d37 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -57,7 +57,7 @@ SYMBOL: terms 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 ) @@ -79,7 +79,7 @@ SYMBOL: terms ] curry each ; : duplicates? ( seq -- ? ) - dup prune [ length ] 2apply > ; + dup prune [ length ] bi@ > ; : (wedge) ( n basis1 basis2 -- n basis ) append dup duplicates? [ @@ -90,7 +90,7 @@ SYMBOL: terms ] if ; : wedge ( x y -- x.y ) - [ >alt ] 2apply [ + [ >alt ] bi@ [ swap [ [ 2swap [ @@ -200,7 +200,7 @@ DEFER: (d) ] 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 } prepend ] map 1 tail dup first length 0 add @@ -278,7 +278,7 @@ DEFER: (d) ] 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 ) diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index 07cd34b4df..52cca64b2f 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -52,7 +52,7 @@ M: cons nil? ( cons -- bool ) TUPLE: lazy-cons car cdr ; : lazy-cons ( car cdr -- promise ) - [ promise ] 2apply \ lazy-cons construct-boa + [ promise ] bi@ \ lazy-cons construct-boa T{ promise f f t f } clone [ set-promise-value ] keep ; diff --git a/extra/levenshtein/levenshtein.factor b/extra/levenshtein/levenshtein.factor index 07e16fb862..98b376593c 100644 --- a/extra/levenshtein/levenshtein.factor +++ b/extra/levenshtein/levenshtein.factor @@ -17,7 +17,7 @@ SYMBOL: d SYMBOL: costs : init-d ( str1 str2 -- ) - [ length 1+ ] 2apply 2dup d set + [ length 1+ ] bi@ 2dup d set [ 0 over ->d ] each [ dup 0 ->d ] each ; inline @@ -39,7 +39,7 @@ SYMBOL: costs [ 2dup init-d 2dup compute-costs - [ length ] 2apply [ + [ length ] bi@ [ [ levenshtein-step ] curry each ] with each levenshtein-result diff --git a/extra/lint/lint.factor b/extra/lint/lint.factor index a220eece01..dcf52f723a 100644 --- a/extra/lint/lint.factor +++ b/extra/lint/lint.factor @@ -71,7 +71,7 @@ def-hash get-global [ ! Remove set-alien-cell, etc. [ - drop [ accessor-words swap seq-diff ] keep [ length ] 2apply = + drop [ accessor-words swap seq-diff ] keep [ length ] bi@ = ] assoc-subset ! Remove trivial defs @@ -148,7 +148,7 @@ GENERIC: run-lint ( obj -- obj ) : filter-symbols ( alist -- alist ) [ nip first dup def-hash get at - [ first ] 2apply literalize = not + [ first ] bi@ literalize = not ] assoc-subset ; M: sequence run-lint ( seq -- seq ) diff --git a/extra/match/match.factor b/extra/match/match.factor index fef925431d..2c6923a6ba 100755 --- a/extra/match/match.factor +++ b/extra/match/match.factor @@ -32,10 +32,10 @@ SYMBOL: _ { [ 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 ; diff --git a/extra/math/complex/complex.factor b/extra/math/complex/complex.factor index 236d9df7a0..588f34d3fc 100755 --- a/extra/math/complex/complex.factor +++ b/extra/math/complex/complex.factor @@ -8,11 +8,11 @@ math.functions.private sequences parser ; 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 ; diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor index 85e07fe73f..dcbccb4316 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -101,7 +101,7 @@ M: real absq sq ; >r - abs r> < ; : ~rel ( x y epsilon -- ? ) - >r [ - abs ] 2keep [ abs ] 2apply + r> * < ; + >r [ - abs ] 2keep [ abs ] bi@ + r> * < ; : ~ ( x y epsilon -- ? ) { @@ -124,7 +124,7 @@ M: real absq sq ; : 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 diff --git a/extra/math/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor index 000d97f2a6..d6ac71e629 100644 --- a/extra/math/polynomials/polynomials.factor +++ b/extra/math/polynomials/polynomials.factor @@ -13,10 +13,10 @@ IN: math.polynomials : p= ( p p -- ? ) pextend = ; @@ -24,7 +24,7 @@ PRIVATE> : ptrim ( p -- p ) dup singleton? [ [ 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 ; @@ -32,7 +32,7 @@ PRIVATE> ! 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. @@ -46,13 +46,13 @@ PRIVATE> : 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 @@ -74,7 +74,7 @@ PRIVATE> ] 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. diff --git a/extra/math/quaternions/quaternions.factor b/extra/math/quaternions/quaternions.factor index d61afd17c3..f121e4a0d1 100755 --- a/extra/math/quaternions/quaternions.factor +++ b/extra/math/quaternions/quaternions.factor @@ -14,7 +14,7 @@ IN: math.quaternions : ** 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 diff --git a/extra/math/ratios/ratios.factor b/extra/math/ratios/ratios.factor index 5d07bd046f..3c430111ff 100755 --- a/extra/math/ratios/ratios.factor +++ b/extra/math/ratios/ratios.factor @@ -7,7 +7,7 @@ USING: kernel kernel.private math math.functions math.private ; dup numerator swap denominator ; inline : 2>fraction ( a/b c/d -- a c b d ) - [ >fraction ] 2apply swapd ; inline + [ >fraction ] bi@ swapd ; inline r /i r> fraction> ] if ; diff --git a/extra/math/statistics/statistics.factor b/extra/math/statistics/statistics.factor index 4c60363be0..f7295604cd 100644 --- a/extra/math/statistics/statistics.factor +++ b/extra/math/statistics/statistics.factor @@ -46,13 +46,13 @@ IN: math.statistics : ((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) ; diff --git a/extra/maze/maze.factor b/extra/maze/maze.factor index 14a493cec5..5d7bb9a1a2 100644 --- a/extra/maze/maze.factor +++ b/extra/maze/maze.factor @@ -22,7 +22,7 @@ SYMBOL: visited : 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 diff --git a/extra/money/money.factor b/extra/money/money.factor index 4058ee9e6a..4584daf592 100644 --- a/extra/money/money.factor +++ b/extra/money/money.factor @@ -23,9 +23,9 @@ TUPLE: not-a-decimal ; : 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: diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index ed82d2478e..ac62fb08f9 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -113,7 +113,7 @@ TUPLE: no-method arguments generic ; ] curry assoc-map ; : sorted-methods ( alist -- alist' ) - [ [ first ] 2apply classes< ] topological-sort ; + [ [ first ] bi@ classes< ] topological-sort ; : niceify-method [ dup \ f eq? [ drop f ] when ] map ; diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 61d3be0e15..84515305c8 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -38,7 +38,7 @@ M: demo-gadget pref-dim* ( gadget -- dim ) : 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 diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 08e3cb204b..36d24e1300 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -8,9 +8,9 @@ math.parser opengl.gl opengl.glu combinators arrays sequences 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 @@ -85,7 +85,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) : 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 ; diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index bf06708e09..d6aacf9645 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -35,7 +35,7 @@ C: parse-result ] if ; : string= ( str1 str2 ignore-case -- ? ) - [ [ >upper ] 2apply ] when sequence= ; + [ [ >upper ] bi@ ] when sequence= ; : string-head? ( str head ignore-case -- ? ) 2over shorter? [ @@ -327,7 +327,7 @@ LAZY: <(+)> ( parser -- parser ) 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 [ flatten ] <@ ; diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 7a82418c27..49035ea43c 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -70,7 +70,7 @@ MEMO: pack ( begin body end -- parser ) >r >r hide r> r> hide 3seq [ first ] action ; : surrounded-by ( parser begin end -- parser' ) - [ token ] 2apply swapd pack ; + [ token ] bi@ swapd pack ; : 'digit' ( -- parser ) [ digit? ] satisfy [ digit> ] action ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 247a64eac2..d6d573da79 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -11,7 +11,7 @@ USE: prettyprint TUPLE: parse-result remaining ast ; TUPLE: parser id compiled ; -M: parser equal? [ id>> ] 2apply = ; +M: parser equal? [ id>> ] bi@ = ; C: parser SYMBOL: ignore diff --git a/extra/project-euler/009/009.factor b/extra/project-euler/009/009.factor index f09643d290..690fed9012 100644 --- a/extra/project-euler/009/009.factor +++ b/extra/project-euler/009/009.factor @@ -31,7 +31,7 @@ IN: project-euler.009 : 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 ; diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor index 02c5dbb9d3..32b1aa5549 100644 --- a/extra/project-euler/014/014.factor +++ b/extra/project-euler/014/014.factor @@ -39,7 +39,7 @@ IN: project-euler.014 dup even? [ 2 / ] [ 3 * 1+ ] if ; : longest ( seq seq -- seq ) - 2dup [ length ] 2apply > [ drop ] [ nip ] if ; + 2dup [ length ] bi@ > [ drop ] [ nip ] if ; PRIVATE> diff --git a/extra/project-euler/026/026.factor b/extra/project-euler/026/026.factor index 3ad1908aa6..f1f546ec1c 100644 --- a/extra/project-euler/026/026.factor +++ b/extra/project-euler/026/026.factor @@ -58,7 +58,7 @@ PRIVATE> : max-period ( seq -- elt n ) dup [ period-length ] map dup supremum - over index [ swap nth ] curry 2apply ; + over index [ swap nth ] curry bi@ ; PRIVATE> diff --git a/extra/project-euler/027/027.factor b/extra/project-euler/027/027.factor index 2bc7894684..2d99204bf3 100644 --- a/extra/project-euler/027/027.factor +++ b/extra/project-euler/027/027.factor @@ -60,7 +60,7 @@ IN: project-euler.027 : 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> diff --git a/extra/project-euler/033/033.factor b/extra/project-euler/033/033.factor index 6f29c3519e..35b1c87e7a 100644 --- a/extra/project-euler/033/033.factor +++ b/extra/project-euler/033/033.factor @@ -33,10 +33,10 @@ IN: project-euler.033 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 = ; diff --git a/extra/project-euler/044/044.factor b/extra/project-euler/044/044.factor index 62e516e4b0..bc8aec8bde 100644 --- a/extra/project-euler/044/044.factor +++ b/extra/project-euler/044/044.factor @@ -31,7 +31,7 @@ IN: project-euler.044 dup 3 * 1- * 2 / ; : sum-and-diff? ( m n -- ? ) - 2dup + -rot - [ pentagonal? ] 2apply and ; + 2dup + -rot - [ pentagonal? ] bi@ and ; PRIVATE> diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor index 30c46de0a0..b4cbd6dbcb 100644 --- a/extra/project-euler/079/079.factor +++ b/extra/project-euler/079/079.factor @@ -35,7 +35,7 @@ IN: project-euler.079 ] { } make ; : find-source ( seq -- elt ) - dup values swap keys [ prune ] 2apply seq-diff + dup values swap keys [ prune ] bi@ seq-diff dup empty? [ "Topological sort failed" throw ] [ first ] if ; : remove-source ( seq elt -- seq ) diff --git a/extra/random-tester/random/random.factor b/extra/random-tester/random/random.factor index 163de69a59..11f2e60d1a 100755 --- a/extra/random-tester/random/random.factor +++ b/extra/random-tester/random/random.factor @@ -54,7 +54,7 @@ IN: random-tester ] if ; : random-ratio ( -- ratio ) - 1000000000 dup [ random ] 2apply 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ; + 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 diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index b57724d1db..fa36a7c6f8 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -16,7 +16,7 @@ SYMBOL: ignore-case? : 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 ; diff --git a/extra/regexp2/regexp2.factor b/extra/regexp2/regexp2.factor index e62eb76cb1..1f2bbde171 100644 --- a/extra/regexp2/regexp2.factor +++ b/extra/regexp2/regexp2.factor @@ -16,7 +16,7 @@ SYMBOL: ignore-case? : 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 ; diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 2614a774dd..7e9496c90d 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -9,7 +9,7 @@ IN: reports.noise { -nrot 5 } { -roll 4 } { -rot 3 } - { 2apply 1 } + { bi@ 1 } { 2curry 1 } { 2drop 1 } { 2dup 1 } diff --git a/extra/roman/roman.factor b/extra/roman/roman.factor index 7466883c5f..a3e61dd889 100644 --- a/extra/roman/roman.factor +++ b/extra/roman/roman.factor @@ -23,7 +23,7 @@ TUPLE: roman-range-error n ; ] 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 ; @@ -57,7 +57,7 @@ PRIVATE> ( str1 str2 -- m n ) - [ roman> ] 2apply ; + [ roman> ] bi@ ; : binary-roman-op ( str1 str2 quot -- str3 ) >r 2roman> r> call >roman ; inline diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 257133c67f..c523053740 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -60,7 +60,7 @@ test-db [ "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 diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index 2865b1fd6c..ac247057f4 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -24,7 +24,7 @@ C: id 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 diff --git a/extra/shufflers/shufflers.factor b/extra/shufflers/shufflers.factor index 172db1def1..b11668a53e 100644 --- a/extra/shufflers/shufflers.factor +++ b/extra/shufflers/shufflers.factor @@ -20,7 +20,7 @@ IN: shufflers : put-effect ( word -- ) dup word-name "-" split1 - [ >array [ 1string ] map ] 2apply + [ >array [ 1string ] map ] bi@ "declared-effect" set-word-prop ; : in-shuffle ( -- ) in get ".shuffle" append set-in ; diff --git a/extra/sudoku/sudoku.factor b/extra/sudoku/sudoku.factor index db5fb75617..764c4d92f0 100644 --- a/extra/sudoku/sudoku.factor +++ b/extra/sudoku/sudoku.factor @@ -18,7 +18,7 @@ SYMBOL: board : 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> ; diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index d1c4b148a5..99af06b80f 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -35,7 +35,7 @@ linkname magic version uname gname devmajor devminor prefix ; : header-checksum ( seq -- x ) 148 cut-slice 8 tail-slice - [ sum ] 2apply + 256 + ; + [ sum ] bi@ + 256 + ; TUPLE: checksum-error ; TUPLE: malformed-block-error ; diff --git a/extra/tools/completion/completion.factor b/extra/tools/completion/completion.factor index e44c3c401e..16bde2100f 100755 --- a/extra/tools/completion/completion.factor +++ b/extra/tools/completion/completion.factor @@ -40,7 +40,7 @@ unicode.categories ; : 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 * + @@ -57,7 +57,7 @@ unicode.categories ; : complete ( full short -- score ) [ dupd fuzzy score ] 2keep - [ ] 2apply + [ ] bi@ dupd fuzzy score max ; : completion ( short candidate -- result ) diff --git a/extra/tools/deploy/shaker/strip-cocoa.factor b/extra/tools/deploy/shaker/strip-cocoa.factor index b37e42f323..de8f8740f0 100755 --- a/extra/tools/deploy/shaker/strip-cocoa.factor +++ b/extra/tools/deploy/shaker/strip-cocoa.factor @@ -14,7 +14,7 @@ global [ sent-messages get super-sent-messages get - [ keys [ objc-methods get at dup ] H{ } map>assoc ] 2apply + [ keys [ objc-methods get at dup ] H{ } map>assoc ] bi@ super-message-senders [ intersect ] change message-senders [ intersect ] change diff --git a/extra/ui/gadgets/borders/borders.factor b/extra/ui/gadgets/borders/borders.factor index e58ba343c7..6b548aaf68 100644 --- a/extra/ui/gadgets/borders/borders.factor +++ b/extra/ui/gadgets/borders/borders.factor @@ -24,7 +24,7 @@ M: border pref-dim* ; : 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 diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index def6b99b05..b3ecad6aed 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -135,7 +135,7 @@ M: editor ungraft* 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 ) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 267f6f0f0f..ddcaa4b979 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -22,7 +22,7 @@ M: array rect-dim drop { 0 0 } ; : 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 ; : ( loc ext -- rect ) over [v-] ; diff --git a/extra/ui/gadgets/grids/grids-tests.factor b/extra/ui/gadgets/grids/grids-tests.factor index 0792d55135..f20275ff25 100644 --- a/extra/ui/gadgets/grids/grids-tests.factor +++ b/extra/ui/gadgets/grids/grids-tests.factor @@ -25,13 +25,13 @@ IN: ui.gadgets.grids.tests [ { 100 200 } ] [ 100x100 100x100 - [ 1array ] 2apply 2array pref-dim + [ 1array ] bi@ 2array pref-dim ] unit-test [ ] [ 100x100 100x100 - [ 1array ] 2apply 2array layout + [ 1array ] bi@ 2array layout ] unit-test [ { 230 120 } { 100 100 } { 100 100 } ] [ diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/extra/ui/gadgets/scrollers/scrollers.factor index 99bd1be876..d4a1895894 100755 --- a/extra/ui/gadgets/scrollers/scrollers.factor +++ b/extra/ui/gadgets/scrollers/scrollers.factor @@ -57,7 +57,7 @@ scroller H{ 2dup control-value = [ 2drop ] [ set-control-value ] if ; : rect-min ( rect1 rect2 -- rect ) - >r [ rect-loc ] keep r> [ rect-dim ] 2apply vmin ; + >r [ rect-loc ] keep r> [ rect-dim ] bi@ vmin ; : (scroll>rect) ( rect scroller -- ) [ diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index dfc7bf2264..4c8c6491ca 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -26,7 +26,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; : process-other-extend ( lines -- set ) [ "#" split1 drop ";" split1 drop trim-blank ] map [ empty? not ] subset - [ ".." split1 [ dup ] unless* [ hex> ] 2apply [a,b] ] map + [ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map concat >set ; : other-extend-lines ( -- lines ) @@ -83,7 +83,7 @@ VALUE: grapheme-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 diff --git a/extra/unicode/case/case.factor b/extra/unicode/case/case.factor index 8129ec17f8..092a247204 100755 --- a/extra/unicode/case/case.factor +++ b/extra/unicode/case/case.factor @@ -100,7 +100,7 @@ SYMBOL: locale ! Just casing locale, or overall? >upper >lower ; : insensitive= ( str1 str2 -- ? ) - [ >case-fold ] 2apply = ; + [ >case-fold ] bi@ = ; : lower? ( string -- ? ) dup >lower = ; diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor index 47637e8330..d62beb1a2c 100644 --- a/extra/unicode/normalize/normalize.factor +++ b/extra/unicode/normalize/normalize.factor @@ -38,7 +38,7 @@ IN: unicode.normalize : (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 diff --git a/extra/units/units.factor b/extra/units/units.factor index b92cbb659a..cf53ceaee3 100755 --- a/extra/units/units.factor +++ b/extra/units/units.factor @@ -16,7 +16,7 @@ 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? @@ -24,7 +24,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; : ( n top bot -- obj ) symbolic-reduce - [ natural-sort ] 2apply + [ natural-sort ] bi@ dimensioned construct-boa ; : >dimensioned< ( d -- n top bot ) @@ -37,10 +37,10 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; { 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@ ; : ; : 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* ; diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor index c7eaafe887..822b290f88 100755 --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -63,7 +63,7 @@ SYMBOL: rule-sets 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 -- ) From 48501f1f6e1ef064ff0f494e38b46f48266a8ab4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Mar 2008 23:11:45 -0500 Subject: [PATCH 300/886] Documentation fixes --- core/combinators/combinators-docs.factor | 40 +++- core/hashtables/hashtables-docs.factor | 18 +- core/kernel/kernel-docs.factor | 283 ++++++++++++++++++++--- core/kernel/kernel.factor | 24 +- extra/help/handbook/handbook.factor | 11 - 5 files changed, 322 insertions(+), 54 deletions(-) diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index f5d4470bde..b088979b4e 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -10,18 +10,54 @@ ARTICLE: "combinators-quot" "Quotation construction utilities" { $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 { "obj..." "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." } diff --git a/core/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor index d62afdffb5..2a4be9c570 100755 --- a/core/hashtables/hashtables-docs.factor +++ b/core/hashtables/hashtables-docs.factor @@ -32,14 +32,28 @@ $nl { $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 all-unique? } ; ABOUT: "hashtables" diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 457313724c..587839f685 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -43,29 +43,86 @@ $nl "An alternative to using " { $link >r } " and " { $link r> } " is the following:" { $subsection dip } ; -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:" -{ $code - ": keep ( x quot -- x )" - " over >r call r> ; inline" -} -"Word inlining is documented in " { $link "declarations" } "." +ARTICLE: "cleave-combinators" "Cleave combinators" +"The cleave combinators apply multiple quotations to a single value." $nl -"There are some words that combine shuffle words with " { $link call } ". They are useful for implementing higher-level combinators." -{ $subsection slip } -{ $subsection 2slip } -{ $subsection keep } -{ $subsection 2keep } -{ $subsection 3keep } +"Two quotations:" +{ $subsection bi } +{ $subsection 2bi } +"Three quotations:" +{ $subsection tri } +{ $subsection 2tri } +"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" +} +"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" } "." +$nl +"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" } +} ; + +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*" +} + +$nl +"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." ; + +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? } -"A looping combinator:" -{ $subsection while } +{ $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 } ; + +ARTICLE: "compositional-combinators" "Compositional combinators" "Quotations can be composed using efficient quotation-specific operations:" { $subsection curry } { $subsection 2curry } @@ -73,8 +130,21 @@ $nl { $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." @@ -115,15 +185,13 @@ ARTICLE: "conditionals" "Conditionals and logic" { $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" @@ -146,7 +214,23 @@ $nl "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 "combinators" } +"Advanced topics:" +{ $subsection "implementing-combinators" } +{ $subsection "continuations" } ; + ABOUT: "dataflow" HELP: eq? ( obj1 obj2 -- ? ) @@ -242,6 +326,8 @@ HELP: equal? { { $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." } { $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:" @@ -376,9 +462,152 @@ HELP: 3keep { $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: 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 swap q" + } + "In general, the following two lines are equivalent:" + { $code + "[ p ] [ q ] 2bi" + "[ p ] 2keep 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: 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 { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } { "x" object } { "y" object } } -{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } "." } ; +{ $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" + } +} ; + +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" + } +} ; + +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" + } +} ; HELP: if ( cond true false -- ) { $values { "cond" "a generalized boolean" } { "true" quotation } { "false" quotation } } diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index e2e0c0171a..70b591e5cf 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -66,46 +66,46 @@ DEFER: if >r 3dup r> -roll 3slip ; inline ! Cleavers -: bi ( x p q -- p[x] q[x] ) +: bi ( x p q -- ) >r keep r> call ; inline -: tri ( x p q r -- p[x] q[x] r[x] ) +: tri ( x p q r -- ) >r pick >r bi r> r> call ; inline ! Double cleavers -: 2bi ( x y p q -- p[x,y] q[x,y] ) +: 2bi ( x y p q -- ) >r 2keep r> call ; inline -: 2tri ( x y p q r -- p[x,y] q[x,y] r[x,y] ) +: 2tri ( x y p q r -- ) >r >r 2keep r> 2keep r> call ; inline ! Triple cleavers -: 3bi ( x y z p q -- p[x,y,z] q[x,y,z] ) +: 3bi ( x y z p q -- ) >r 3keep r> call ; inline -: 3tri ( x y z p q r -- p[x,y,z] q[x,y,z] r[x,y,z] ) +: 3tri ( x y z p q r -- ) >r >r 3keep r> 3keep r> call ; inline ! Spreaders -: bi* ( x y p q -- p[x] q[y] ) +: bi* ( x y p q -- ) >r swap slip r> call ; inline -: tri* ( x y z p q r -- p[x] q[y] r[z] ) +: tri* ( x y z p q r -- ) >r rot >r bi* r> r> call ; inline ! Double spreaders -: 2bi* ( w x y z p q -- p[w,x] q[y,z] ) +: 2bi* ( w x y z p q -- ) >r -rot 2slip r> call ; inline ! Appliers -: bi@ ( x y p -- p[x] p[y] ) +: bi@ ( x y p -- ) tuck 2slip call ; inline -: tri@ ( x y z p -- p[x] p[y] p[z] ) +: tri@ ( x y z p -- ) tuck >r bi@ r> call ; inline ! Double appliers -: 2bi@ ( w x y z p -- p[w,x] p[y,z] ) +: 2bi@ ( w x y z p -- ) dup -roll 3slip call ; inline : while ( pred body tail -- ) diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 8963c2b1ad..912c3c35f3 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -68,17 +68,6 @@ ARTICLE: "evaluator" "Evaluation semantics" "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 From 726806b1c14a6f0972acff54959ace69b61b5213 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Mar 2008 23:11:54 -0500 Subject: [PATCH 301/886] More robust concurrency.distributed unit test --- extra/concurrency/distributed/distributed-tests.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor index 0941eb4251..856c37a6bc 100755 --- a/extra/concurrency/distributed/distributed-tests.factor +++ b/extra/concurrency/distributed/distributed-tests.factor @@ -1,7 +1,7 @@ IN: concurrency.distributed.tests USING: tools.test concurrency.distributed kernel io.files arrays io.sockets system combinators threads math sequences -concurrency.messaging ; +concurrency.messaging continuations ; : test-node { @@ -9,6 +9,8 @@ concurrency.messaging ; { [ windows? ] [ "127.0.0.1" 1238 ] } } cond ; +[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test + [ ] [ test-node dup 1array swap (start-node) ] unit-test [ ] [ yield ] unit-test From af9e27823a3840438ab1ba0b74a7bb899e38ff84 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sun, 30 Mar 2008 17:17:31 +1300 Subject: [PATCH 302/886] Add => action rule for an entire sequence --- extra/peg/ebnf/ebnf-tests.factor | 17 +++++++++++++++++ extra/peg/ebnf/ebnf.factor | 23 ++++++++++++++++++----- 2 files changed, 35 insertions(+), 5 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index c2c0a50a59..7aa61e84da 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -144,6 +144,23 @@ IN: peg.ebnf.tests "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 + + { V{ V{ 49 } "+" V{ 49 } } } [ #! Test direct left recursion. #! Using packrat, so first part of expr fails, causing 2nd choice to be used diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index c1e2ce8546..af61c3aae0 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -111,7 +111,10 @@ C: ebnf 'range-parser' , 'any-character' , ] choice* , - "=" syntax ensure-not , + [ + "=" syntax ensure-not , + "=>" syntax ensure , + ] choice* , ] seq* [ first ] action ; DEFER: 'choice' @@ -176,7 +179,10 @@ DEFER: 'choice' 'repeat0' sp , 'repeat1' sp , 'optional' sp , - ] choice* ; + ] choice* ; + +: 'action' ( -- parser ) + "[[" 'factor-code' "]]" syntax-pack ; : 'sequence' ( -- parser ) #! A sequence of terminals and non-terminals, including @@ -184,15 +190,21 @@ DEFER: 'choice' [ [ ('sequence') , - "[[" 'factor-code' "]]" syntax-pack , + 'action' , ] seq* [ first2 ] action , ('sequence') , ] choice* repeat1 [ dup length 1 = [ first ] [ ] if ] action ; + +: 'actioned-sequence' ( -- parser ) + [ + [ 'sequence' , "=>" syntax , 'action' , ] seq* [ first2 ] action , + 'sequence' , + ] choice* ; : 'choice' ( -- parser ) - 'sequence' sp "|" token sp list-of [ + 'actioned-sequence' sp "|" token sp list-of [ dup length 1 = [ first ] [ ] if ] action ; @@ -200,7 +212,8 @@ DEFER: 'choice' [ 'non-terminal' [ symbol>> ] action , "=" syntax , - 'choice' , + ">" token ensure-not , + 'choice' , ] seq* [ first2 ] action ; : 'ebnf' ( -- parser ) From d002e029485339ff7c15cdbfb20867e59304c3d0 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sun, 30 Mar 2008 17:23:11 +1300 Subject: [PATCH 303/886] Use left recursive grammar in peg.expr --- extra/peg/expr/expr.factor | 25 ++++++++++--------------- 1 file changed, 10 insertions(+), 15 deletions(-) diff --git a/extra/peg/expr/expr.factor b/extra/peg/expr/expr.factor index 6b690cb5ee..e16d9db0a7 100644 --- a/extra/peg/expr/expr.factor +++ b/extra/peg/expr/expr.factor @@ -4,24 +4,19 @@ USING: kernel arrays strings math.parser sequences peg peg.ebnf peg.parsers memoize math ; IN: peg.expr -: operator-fold ( lhs seq -- value ) - #! Perform a fold of a lhs, followed by a sequence of pairs being - #! { operator rhs } in to a tree structure of the correct precedence. - swap [ first2 swap call ] reduce ; - EBNF: expr -times = "*" [[ drop [ * ] ]] -divide = "/" [[ drop [ / ] ]] -add = "+" [[ drop [ + ] ]] -subtract = "-" [[ drop [ - ] ]] +digit = [0-9] => [[ digit> ]] +number = (digit)+ => [[ 10 digits>integer ]] +value = number + | ("(" exp ")") => [[ second ]] -digit = [0-9] [[ digit> ]] -number = (digit)+ [[ unclip [ swap 10 * + ] reduce ]] +fac = fac "*" value => [[ first3 nip * ]] + | fac "/" value => [[ first3 nip / ]] + | number -value = number | ("(" expr ")") [[ second ]] -product = (value ((times | divide) value)*) [[ first2 operator-fold ]] -sum = (product ((add | subtract) product)*) [[ first2 operator-fold ]] -expr = sum +exp = exp "+" fac => [[ first3 nip + ]] + | exp "-" fac => [[ first3 nip - ]] + | fac ;EBNF : eval-expr ( string -- number ) From a23e0ce15c97e58ea0f4de621ea4f77c5422b791 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sun, 30 Mar 2008 17:35:47 +1300 Subject: [PATCH 304/886] Fix hashcode* on parsers --- extra/peg/peg.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 247a64eac2..8621b43a7f 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -12,6 +12,8 @@ TUPLE: parse-result remaining ast ; TUPLE: parser id compiled ; M: parser equal? [ id>> ] 2apply = ; +M: parser hashcode* ( depth obj -- code ) + id>> hashcode* ; C: parser SYMBOL: ignore From 8eb55b4c591d3da3b316b3c54485eb571c5ed428 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Mar 2008 23:48:06 -0500 Subject: [PATCH 305/886] More doc fixes --- core/kernel/kernel-docs.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 587839f685..a446869096 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -295,12 +295,12 @@ 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 } } From a89e0b7615a775f0ceb921a464b8f3645fc9ff40 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 00:13:53 -0500 Subject: [PATCH 306/886] Fix deploy tests for AMD64 --- extra/tools/deploy/deploy-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 5030763a3d..f104fb0210 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -1,7 +1,7 @@ IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config tools.deploy.backend math sequences io.launcher arrays -namespaces continuations ; +namespaces continuations layouts ; : shake-and-bake ( vocab -- ) [ "test.image" temp-file delete-file ] ignore-errors @@ -17,7 +17,7 @@ namespaces continuations ; [ ] [ "hello-world" shake-and-bake ] unit-test [ t ] [ - 500000 small-enough? + cell 8 = 8 5 ? 100000 * small-enough? ] unit-test [ ] [ "sudoku" shake-and-bake ] unit-test From 2d19b386839095f66ad3f9895b629bdbb1ac1c33 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 00:40:43 -0500 Subject: [PATCH 307/886] Documentation fixes --- core/combinators/combinators-docs.factor | 2 +- core/combinators/combinators.factor | 6 +++--- core/kernel/kernel.factor | 6 +++--- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index b088979b4e..f497fd20e5 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -45,7 +45,7 @@ HELP: cleave { bi tri cleave } related-words HELP: spread -{ $values { "obj..." "objects" } { "seq" "a sequence of quotations with stack effect " { $snippet "( x -- ... )" } } } +{ $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:" diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index cc03955fd8..e19847dbd4 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -5,13 +5,13 @@ USING: arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors hashtables sorting ; -: cleave ( obj seq -- ) +: cleave ( x seq -- ) [ call ] with each ; : cleave>quot ( seq -- quot ) [ [ keep ] curry ] map concat [ drop ] append ; -: 2cleave ( obj seq -- ) +: 2cleave ( x seq -- ) [ [ call ] 3keep drop ] each 2drop ; : 2cleave>quot ( seq -- quot ) @@ -22,7 +22,7 @@ hashtables sorting ; [ [ [ r> ] prepend ] map concat ] bi append ; -: spread ( seq -- ) +: spread ( objs... seq -- ) spread>quot call ; ERROR: no-cond ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 70b591e5cf..ab42a1b903 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -98,14 +98,14 @@ DEFER: if >r -rot 2slip r> call ; inline ! Appliers -: bi@ ( x y p -- ) +: bi@ ( x y quot -- ) tuck 2slip call ; inline -: tri@ ( x y z p -- ) +: tri@ ( x y z quot -- ) tuck >r bi@ r> call ; inline ! Double appliers -: 2bi@ ( w x y z p -- ) +: 2bi@ ( w x y z quot -- ) dup -roll 3slip call ; inline : while ( pred body tail -- ) From 4ca0c492807c2a1b58aabd6b97824c4e317125cf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 00:47:48 -0500 Subject: [PATCH 308/886] Fix buggy benchmarks --- extra/benchmark/typecheck2/typecheck2.factor | 2 +- extra/benchmark/typecheck3/typecheck3.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/benchmark/typecheck2/typecheck2.factor b/extra/benchmark/typecheck2/typecheck2.factor index d7977063ee..0fc1debb67 100644 --- a/extra/benchmark/typecheck2/typecheck2.factor +++ b/extra/benchmark/typecheck2/typecheck2.factor @@ -3,7 +3,7 @@ IN: benchmark.typecheck2 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 ; diff --git a/extra/benchmark/typecheck3/typecheck3.factor b/extra/benchmark/typecheck3/typecheck3.factor index e85fb2850c..9a58e0a795 100644 --- a/extra/benchmark/typecheck3/typecheck3.factor +++ b/extra/benchmark/typecheck3/typecheck3.factor @@ -3,7 +3,7 @@ IN: benchmark.typecheck3 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 ; From 78633e03a0d9951407e33c01c8e33eac0205657e Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sun, 30 Mar 2008 19:01:47 +1300 Subject: [PATCH 309/886] Allow var names in ebnf but ignore them for now --- extra/peg/ebnf/ebnf.factor | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index af61c3aae0..0ae1430c8c 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -19,6 +19,7 @@ TUPLE: ebnf-repeat1 group ; TUPLE: ebnf-optional group ; TUPLE: ebnf-rule symbol elements ; TUPLE: ebnf-action parser code ; +TUPLE: ebnf-var parser name ; TUPLE: ebnf rules ; C: ebnf-non-terminal @@ -34,6 +35,7 @@ C: ebnf-repeat1 C: ebnf-optional C: ebnf-rule C: ebnf-action +C: ebnf-var C: ebnf : syntax ( string -- parser ) @@ -79,6 +81,7 @@ C: ebnf [ dup CHAR: * = ] [ dup CHAR: + = ] [ dup CHAR: ? = ] + [ dup CHAR: : = ] } || not nip ] satisfy repeat1 [ >string ] action ; @@ -200,6 +203,7 @@ DEFER: 'choice' : 'actioned-sequence' ( -- parser ) [ [ 'sequence' , "=>" syntax , 'action' , ] seq* [ first2 ] action , + [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 ] action , 'sequence' , ] choice* ; @@ -270,6 +274,9 @@ M: ebnf-action (transform) ( ast -- parser ) [ parser>> (transform) ] keep code>> string-lines [ parse-lines ] with-compilation-unit action ; +M: ebnf-var (transform) ( ast -- parser ) + parser>> (transform) ; + M: ebnf-terminal (transform) ( ast -- parser ) symbol>> token sp ; From f49d26e8d060c745b31dd72454462d0625cef2eb Mon Sep 17 00:00:00 2001 From: erg Date: Sun, 30 Mar 2008 01:13:29 -0500 Subject: [PATCH 310/886] make copy-tree and delete-tree symlink aware --- core/io/files/files.factor | 30 ++++++++++++++++++------------ extra/io/unix/files/files.factor | 19 +++++++++++++++---- extra/unix/unix.factor | 4 ++++ 3 files changed, 37 insertions(+), 16 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 48098e612d..4dbbb869c4 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -3,7 +3,7 @@ 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 init ; +io.encodings.binary init accessors ; IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) @@ -145,8 +145,14 @@ PRIVATE> 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 ( path1 path2 -- ) + +HOOK: read-link io-backend ( path -- info ) + SYMBOL: +regular-file+ SYMBOL: +directory+ SYMBOL: +character-device+ @@ -218,14 +224,14 @@ HOOK: delete-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 append-path ; @@ -258,10 +264,10 @@ M: object copy-file DEFER: copy-tree-into : copy-tree ( from to -- ) - over directory? [ - >r dup directory swap r> [ - >r swap first append-path r> copy-tree-into - ] 2curry each + over link-info type>> +directory+ = [ + >r dup directory r> rot [ + [ >r first r> copy-tree-into ] curry each + ] with-directory ] [ copy-file ] if ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 3b493d2fe4..759ac2bec1 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -3,7 +3,7 @@ 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 calendar -io.encodings.binary ; +io.encodings.binary accessors sequences strings ; IN: io.unix.files @@ -49,7 +49,7 @@ M: unix-io touch-file ( path -- ) close ; M: unix-io move-file ( from to -- ) - [ normalize-pathname ] 2apply rename io-error ; + [ normalize-pathname ] bi@ rename io-error ; M: unix-io delete-file ( path -- ) normalize-pathname unlink io-error ; @@ -69,7 +69,7 @@ M: unix-io delete-directory ( path -- ) ] with-disposal ; M: unix-io copy-file ( from to -- ) - [ normalize-pathname ] 2apply + [ normalize-pathname ] bi@ [ (copy-file) ] [ swap file-info file-info-permissions chmod io-error ] 2bi ; @@ -84,7 +84,7 @@ M: unix-io copy-file ( from to -- ) { [ dup S_ISLNK ] [ +symbolic-link+ ] } { [ dup S_ISSOCK ] [ +socket+ ] } { [ t ] [ +unknown+ ] } - } cond nip ; + } cond nip ; : stat>file-info ( stat -- info ) { @@ -100,3 +100,14 @@ M: unix-io file-info ( path -- info ) M: unix-io link-info ( path -- info ) normalize-pathname lstat* stat>file-info ; + +M: unix-io make-link ( path1 path2 -- ) + normalize-pathname symlink io-error ; + +M: unix-io read-link ( path -- path' ) + normalize-pathname + PATH_MAX [ tuck ] [ ] bi readlink + dup io-error head-slice >string ; + +: copy-link ( path1 path2 -- ) + >r read-link r> make-link ; diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index bed87ebd0f..ffd102901c 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -77,6 +77,7 @@ FUNCTION: int pclose ( void* file ) ; 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 ) ; @@ -93,6 +94,7 @@ FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_ 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 ) ; @@ -102,6 +104,8 @@ 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 From b4d2a0b1051061b37a68e80a92bd8673eaa30fb5 Mon Sep 17 00:00:00 2001 From: erg Date: Sun, 30 Mar 2008 01:14:28 -0500 Subject: [PATCH 311/886] add constant to grovel --- build-support/grovel.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/build-support/grovel.c b/build-support/grovel.c index 2eee054dab..db16aa9bca 100644 --- a/build-support/grovel.c +++ b/build-support/grovel.c @@ -42,6 +42,7 @@ #include #include #include + #include #include #include #endif @@ -146,6 +147,7 @@ void unix_constants() constant(PROT_WRITE); constant(MAP_FILE); constant(MAP_SHARED); + constant(PATH_MAX); grovel(pid_t); } From 68e49c8770fc2d9f32382250e0b44026d306115a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 02:21:55 -0500 Subject: [PATCH 312/886] Another benchmark fix --- extra/benchmark/typecheck4/typecheck4.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/benchmark/typecheck4/typecheck4.factor b/extra/benchmark/typecheck4/typecheck4.factor index a1362a68ab..eb211e97e7 100644 --- a/extra/benchmark/typecheck4/typecheck4.factor +++ b/extra/benchmark/typecheck4/typecheck4.factor @@ -3,7 +3,7 @@ IN: benchmark.typecheck4 TUPLE: hello n ; -: hello-n* 4 slot ; +: hello-n* 3 slot ; : foo 0 100000000 [ over hello-n* + ] times ; From ea12d45337d6361840f94f9b733d5a59169056ed Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 03:06:28 -0500 Subject: [PATCH 313/886] Update json for inheritance --- extra/json/writer/writer.factor | 28 +++++++++++----------------- 1 file changed, 11 insertions(+), 17 deletions(-) diff --git a/extra/json/writer/writer.factor b/extra/json/writer/writer.factor index f847bbff68..1741b96e75 100644 --- a/extra/json/writer/writer.factor +++ b/extra/json/writer/writer.factor @@ -1,8 +1,8 @@ ! 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 classes.tuple 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 @@ -39,25 +39,19 @@ M: sequence json-print ( array -- string ) #! javascript variable names. [ (jsvar-encode) ] map ; -: 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 ; +: tuple>fields ( object -- string ) + [ + [ swap jsvar-encode >json % " : " % >json % ] "" make + ] { } assoc>map ; -: 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: tuple json-print ( tuple -- string ) + CHAR: { write1 tuple>fields "," join write CHAR: } write1 ; M: hashtable json-print ( hashtable -- string ) CHAR: { write1 [ [ swap jsvar-encode >json % CHAR: : , >json % ] "" make ] { } assoc>map "," join write CHAR: } write1 ; - + +M: object json-print ( object -- string ) + unparse json-print ; From bb8198d3d0163e0cacc701e21588c16e858d2b08 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sun, 30 Mar 2008 23:24:02 +1300 Subject: [PATCH 314/886] Declare stack effects for compiled parsers --- extra/peg/ebnf/ebnf.factor | 4 ++-- extra/peg/peg.factor | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 0ae1430c8c..41b5a1b655 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -3,7 +3,7 @@ USING: kernel compiler.units parser words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg peg.parsers unicode.categories multiline combinators.lib - splitting accessors ; + splitting accessors effects ; IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; @@ -310,5 +310,5 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) : EBNF: CREATE-WORD dup ";EBNF" parse-multiline-string - ebnf>quot swapd define "ebnf-parser" set-word-prop ; parsing + ebnf>quot swapd 1 1 define-declared "ebnf-parser" set-word-prop ; parsing diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 8621b43a7f..a09962783b 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -3,7 +3,7 @@ USING: kernel sequences strings namespaces math assocs shuffle vectors arrays combinators.lib math.parser match unicode.categories sequences.lib compiler.units parser - words quotations effects memoize accessors locals ; + words quotations effects memoize accessors locals effects ; IN: peg USE: prettyprint @@ -206,7 +206,7 @@ GENERIC: (compile) ( parser -- quot ) :: parser-body ( parser -- quot ) #! Return the body of the word that is the compiled version #! of the parser. - [let* | rule [ parser (compile) define-temp dup parser "peg" set-word-prop ] + [let* | rule [ gensym dup parser (compile) 0 1 define-declared dup parser "peg" set-word-prop ] | [ rule pos get apply-rule dup fail = [ @@ -216,7 +216,7 @@ GENERIC: (compile) ( parser -- quot ) ] if ] ] ; - + : compiled-parser ( parser -- word ) #! Look to see if the given parser has been compiled. #! If not, compile it to a temporary word, cache it, @@ -227,7 +227,7 @@ GENERIC: (compile) ( parser -- quot ) dup compiled>> [ nip ] [ - gensym tuck >>compiled 2dup parser-body define dupd "peg" set-word-prop + gensym tuck >>compiled 2dup parser-body 0 1 define-declared dupd "peg" set-word-prop ] if* ; : compile ( parser -- word ) From 883c54e07765773cf3a30d9478c7f45e14747f39 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 30 Mar 2008 06:45:38 -0500 Subject: [PATCH 315/886] use srandom and prandom on openbsd /dev/random is reserved for hardware rngs.. --- extra/random/unix/unix.factor | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor index 51574887e3..f3f55007f0 100644 --- a/extra/random/unix/unix.factor +++ b/extra/random/unix/unix.factor @@ -1,6 +1,6 @@ USING: alien.c-types io io.files io.nonblocking kernel namespaces random io.encodings.binary singleton init -accessors ; +accessors system ; IN: random.unix TUPLE: unix-random path ; @@ -15,7 +15,14 @@ C: unix-random M: unix-random random-bytes* ( n tuple -- byte-array ) path>> file-read-unbuffered ; -[ - "/dev/random" secure-random-generator set-global - "/dev/urandom" insecure-random-generator set-global -] "random.unix" add-init-hook +os "openbsd" = [ + [ + "/dev/srandom" secure-random-generator set-global + "/dev/prandom" insecure-random-generator set-global + ] "random.unix" add-init-hook +] [ + [ + "/dev/random" secure-random-generator set-global + "/dev/urandom" insecure-random-generator set-global + ] "random.unix" add-init-hook +] if From 5989680a7b992b392dbb57ca99f3909140f2b879 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 31 Mar 2008 00:53:33 +1300 Subject: [PATCH 316/886] Ensure box parsers are never cached --- extra/peg/peg.factor | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index a09962783b..e07942a3cd 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -488,8 +488,11 @@ 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. - quot>> call compiled-parser 1quotation ; + #! 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> @@ -560,7 +563,12 @@ PRIVATE> delay-parser construct-boa init-parser ; : box ( quot -- parser ) - box-parser construct-boa init-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. + box-parser construct-boa next-id f over set-delegate ; : PEG: (:) [ From 8bc2589a7a75bdee2e8c5c057b240a74f5eab062 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 08:16:07 -0500 Subject: [PATCH 317/886] Documentation updates --- core/kernel/kernel-docs.factor | 69 ++++++++++++++++++++++++----- extra/help/cookbook/cookbook.factor | 33 ++++++++++---- 2 files changed, 84 insertions(+), 18 deletions(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index a446869096..1c88f5a485 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -7,6 +7,8 @@ IN: kernel 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 } @@ -39,9 +41,28 @@ $nl { $code ": foo ( m ? n -- m+n/n )" " >r [ r> + ] [ drop r> ] if ; ! This is OK" -} -"An alternative to using " { $link >r } " and " { $link r> } " is the following:" -{ $subsection dip } ; +} ; + +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." @@ -49,9 +70,11 @@ $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" @@ -66,13 +89,38 @@ $nl "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: "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 -"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" } +"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 + ": 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" @@ -96,7 +144,8 @@ $nl } $nl -"A generalization of the above combinators to any number of quotations can be found in " { $link "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." diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index 319dd1586b..075ce2d0e8 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -267,16 +267,33 @@ $nl } ; 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. Imperitive 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." ; From df8dabaf5e56c00fb5eacdb8de167bf6c63d6675 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 08:16:19 -0500 Subject: [PATCH 318/886] Update JSON writer for inheritance --- extra/json/writer/writer.factor | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/extra/json/writer/writer.factor b/extra/json/writer/writer.factor index 1741b96e75..6ad0774e38 100644 --- a/extra/json/writer/writer.factor +++ b/extra/json/writer/writer.factor @@ -26,32 +26,27 @@ M: number json-print ( num -- ) 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 ; -: tuple>fields ( object -- string ) +: tuple>fields ( object -- seq ) [ [ swap jsvar-encode >json % " : " % >json % ] "" make ] { } assoc>map ; -M: tuple json-print ( tuple -- string ) +M: tuple json-print ( tuple -- ) CHAR: { write1 tuple>fields "," join write CHAR: } write1 ; -M: hashtable json-print ( hashtable -- string ) +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 -- string ) +M: object json-print ( object -- ) unparse json-print ; From 87539b8f4eb4b8be3f3770155dcc9ddf608ceced Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 08:16:30 -0500 Subject: [PATCH 319/886] Clean up db.types --- extra/db/types/types.factor | 20 ++++++-------------- 1 file changed, 6 insertions(+), 14 deletions(-) diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 3c73a933e9..9babfbcdb0 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -131,25 +131,17 @@ TUPLE: no-sql-modifier ; 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* ; - : 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-slots [ slot-spec-name ] map - swap tuple-slots 2array flip [ nip ] assoc-subset ; + [ nip ] assoc-subset ; : tuple>params ( specs tuple -- obj ) [ From 856173f54e20f82ab8eb78e99f58e0c4234b930f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 30 Mar 2008 10:46:07 -0500 Subject: [PATCH 320/886] Add unit test --- extra/io/sockets/sockets-tests.factor | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 extra/io/sockets/sockets-tests.factor diff --git a/extra/io/sockets/sockets-tests.factor b/extra/io/sockets/sockets-tests.factor new file mode 100644 index 0000000000..1810b8587b --- /dev/null +++ b/extra/io/sockets/sockets-tests.factor @@ -0,0 +1,4 @@ +IN: io.sockets.tests +USING: io.sockets sequences math tools.test ; + +[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test From cb7d655639a412581b8c7036c68ae8141d900f17 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 30 Mar 2008 10:55:47 -0500 Subject: [PATCH 321/886] move addrinfo into *bsd files --- extra/unix/bsd/bsd.factor | 10 ---------- extra/unix/bsd/freebsd/freebsd.factor | 11 +++++++++++ extra/unix/bsd/macosx/macosx.factor | 11 +++++++++++ extra/unix/bsd/netbsd/netbsd.factor | 11 +++++++++++ extra/unix/bsd/openbsd/openbsd.factor | 11 +++++++++++ 5 files changed, 44 insertions(+), 10 deletions(-) diff --git a/extra/unix/bsd/bsd.factor b/extra/unix/bsd/bsd.factor index cb7b347c20..6cb5d6385b 100755 --- a/extra/unix/bsd/bsd.factor +++ b/extra/unix/bsd/bsd.factor @@ -24,16 +24,6 @@ IN: unix : 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" } diff --git a/extra/unix/bsd/freebsd/freebsd.factor b/extra/unix/bsd/freebsd/freebsd.factor index 94bb708527..f25cbd1537 100644 --- a/extra/unix/bsd/freebsd/freebsd.factor +++ b/extra/unix/bsd/freebsd/freebsd.factor @@ -1,3 +1,14 @@ +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" } ; diff --git a/extra/unix/bsd/macosx/macosx.factor b/extra/unix/bsd/macosx/macosx.factor index 3c0617ad17..edef2aaa0c 100644 --- a/extra/unix/bsd/macosx/macosx.factor +++ b/extra/unix/bsd/macosx/macosx.factor @@ -1,3 +1,14 @@ +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" } ; diff --git a/extra/unix/bsd/netbsd/netbsd.factor b/extra/unix/bsd/netbsd/netbsd.factor index ac18749830..071daa682d 100644 --- a/extra/unix/bsd/netbsd/netbsd.factor +++ b/extra/unix/bsd/netbsd/netbsd.factor @@ -1,3 +1,14 @@ +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" } ; diff --git a/extra/unix/bsd/openbsd/openbsd.factor b/extra/unix/bsd/openbsd/openbsd.factor index 3c0617ad17..29b44f7da6 100644 --- a/extra/unix/bsd/openbsd/openbsd.factor +++ b/extra/unix/bsd/openbsd/openbsd.factor @@ -1,3 +1,14 @@ +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" } ; From 271ef297220202ab492fb8517bc699ebca7526c2 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 30 Mar 2008 12:18:42 -0500 Subject: [PATCH 322/886] Formatting license --- license.txt | 46 ++++++++++++++++++++++------------------------ 1 file changed, 22 insertions(+), 24 deletions(-) diff --git a/license.txt b/license.txt index 87f170da8c..768c13c549 100644 --- a/license.txt +++ b/license.txt @@ -1,24 +1,22 @@ -/* - * 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. From d367dc8462397b6de8f162098516d57b18533959 Mon Sep 17 00:00:00 2001 From: sheeple Date: Sun, 30 Mar 2008 12:21:44 -0500 Subject: [PATCH 323/886] fix gdb on freebsd --- extra/tools/disassembler/disassembler.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index 479ae9c42c..927f7111fa 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -26,11 +26,14 @@ M: pair make-disassemble-cmd M: method-spec make-disassemble-cmd first2 method make-disassemble-cmd ; +: gdb-binary ( -- string ) + os "freebsd" = "gdb66" "gdb" ? ; + : run-gdb ( -- lines ) +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 ; From 6ece2fbde270b4b1c725f84e09e701fc66723642 Mon Sep 17 00:00:00 2001 From: erg Date: Sun, 30 Mar 2008 14:48:49 -0500 Subject: [PATCH 324/886] fix copy-tree --- core/io/files/files.factor | 20 +++++++++++++------- extra/io/unix/files/files.factor | 3 --- 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 4dbbb869c4..458a9145a6 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -153,6 +153,9 @@ HOOK: make-link io-backend ( path1 path2 -- ) HOOK: read-link io-backend ( path -- info ) +: copy-link ( path1 path2 -- ) + >r read-link r> make-link ; + SYMBOL: +regular-file+ SYMBOL: +directory+ SYMBOL: +character-device+ @@ -264,13 +267,16 @@ M: object copy-file DEFER: copy-tree-into : copy-tree ( from to -- ) - over link-info type>> +directory+ = [ - >r dup directory r> rot [ - [ >r first r> copy-tree-into ] curry each - ] with-directory - ] [ - copy-file - ] if ; + 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 ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 759ac2bec1..c4e506d37f 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -108,6 +108,3 @@ M: unix-io read-link ( path -- path' ) normalize-pathname PATH_MAX [ tuck ] [ ] bi readlink dup io-error head-slice >string ; - -: copy-link ( path1 path2 -- ) - >r read-link r> make-link ; From 2d80153b073bca7332f38c15e928c396aa028d7b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 30 Mar 2008 14:39:13 -0600 Subject: [PATCH 325/886] builder: Add support for gmake --- extra/builder/builder.factor | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 461d951209..75664ce5e5 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -48,15 +48,31 @@ IN: builder : record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ; -: do-make-clean ( -- ) { "make" "clean" } try-process ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: gnu-make ( -- string ) + os { "freebsd" "openbsd" "netbsd" } member? + [ "gmake" ] + [ "make" ] + if ; + +! : do-make-clean ( -- ) { "make" "clean" } try-process ; + +: do-make-clean ( -- ) { gnu-make "clean" } to-strings try-process ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! : make-vm ( -- desc ) +! +! { "make" } >>command +! "../compile-log" >>stdout +! +stdout+ >>stderr ; + : make-vm ( -- desc ) - { "make" } >>command - "../compile-log" >>stdout - +stdout+ >>stderr ; + { gnu-make } to-strings >>command + "../compile-log" >>stdout + +stdout+ >>stderr ; : do-make-vm ( -- ) make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ; From 71283f7fc59ca52e8b63ebae8320d0cdbc79e529 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 17:21:58 -0500 Subject: [PATCH 326/886] Documentation update --- core/kernel/kernel-docs.factor | 39 +++++++++++++++++++++++++++++++++- 1 file changed, 38 insertions(+), 1 deletion(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 1c88f5a485..b1120de8e6 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -545,7 +545,7 @@ HELP: 2bi "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 swap q" + "2dup p -rot q" } "In general, the following two lines are equivalent:" { $code @@ -554,6 +554,27 @@ HELP: 2bi } } ; +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" } "." } @@ -591,6 +612,22 @@ HELP: 2tri } } ; +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 -- ... )" } } } From cd85b545bd28d0c1cde36376a2f60acc98a1cf12 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 17:23:42 -0500 Subject: [PATCH 327/886] Cleaning up tuples --- core/classes/tuple/tuple.factor | 99 ++++++++++++++++++++------------- core/slots/slots.factor | 3 - 2 files changed, 59 insertions(+), 43 deletions(-) diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index a452d0eeec..401a421c51 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -23,8 +23,15 @@ M: 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 first -- array ) + [ array-nth ] curry map r> add* ; + PRIVATE> : check-tuple ( class -- ) @@ -32,28 +39,29 @@ PRIVATE> [ drop ] [ no-tuple-class ] if ; : tuple>array ( tuple -- array ) - dup tuple-layout - [ layout-size swap [ array-nth ] curry map ] keep - layout-class add* ; + prepare-tuple>array >r copy-tuple-slots r> layout-class add* ; -: >tuple ( seq -- tuple ) - dup first tuple-layout [ - >r 1 tail-slice dup length r> - [ tuple-size min ] keep - [ set-array-nth ] curry - 2each +: tuple-slots ( tuple -- array ) + prepare-tuple>array drop copy-tuple-slots ; + +: slots>tuple ( tuple class -- array ) + tuple-layout [ + [ tuple-size ] [ [ set-array-nth ] curry ] bi 2each ] keep ; +: >tuple ( tuple -- array ) + unclip slots>tuple ; + : slot-names ( class -- seq ) - "slots" word-prop [ name>> ] map ; + "slot-names" word-prop ; r over r> array-nth >r array-nth r> = ] 2curry - all-integers? + 2dup [ tuple-layout ] bi@ eq? [ + [ drop tuple-size ] + [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ] + 2bi all-integers? ] [ 2drop f ] if ; @@ -92,18 +100,19 @@ PRIVATE> superclasses 1 head-slice* [ slot-names length ] map sum ; -: generate-tuple-slots ( class slots -- slots ) +: generate-tuple-slots ( class slots -- slot-specs ) over superclass-size 2 + simple-slots ; -: define-tuple-slots ( class slots -- ) - dupd generate-tuple-slots +: define-tuple-slots ( class -- ) + dup dup slot-names generate-tuple-slots [ "slots" set-word-prop ] - [ define-accessors ] - [ define-slots ] 2tri ; + [ define-accessors ] ! new + [ define-slots ] ! old + 2tri ; : make-tuple-layout ( class -- layout ) [ ] - [ [ superclass-size ] [ "slots" word-prop length ] bi + ] + [ [ superclass-size ] [ slot-names length ] bi + ] [ superclasses dup length 1- ] tri ; @@ -113,7 +122,7 @@ PRIVATE> : removed-slots ( class newslots -- seq ) swap slot-names seq-diff ; -: forget-slots ( class slots -- ) +: forget-removed-slots ( class slots -- ) dupd removed-slots [ [ reader-word forget-method ] [ writer-word forget-method ] 2bi @@ -122,36 +131,48 @@ PRIVATE> : 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 ; +: all-slot-names ( class -- slots ) + superclasses [ slot-names ] map concat \ class add* ; -: reshape-tuples ( class superclass newslots -- ) - nip - >r dup slot-names r> permutation - [ - >r "predicate" word-prop instances dup - r> [ reshape-tuple ] curry map - become - ] 2curry after-compilation ; +: slot-permutation ( class superclass newslots -- n permutation ) + [ all-slot-names ] [ all-slot-names ] [ ] tri* append + [ drop length ] [ permutation ] 2bi ; + +: permute-direct-slots ( oldslots permutation -- newslots ) + [ [ swap ?nth ] [ drop f ] if* ] with map ; + +: permute-all-slots ( oldslots n permutation -- newslots ) + [ >r head r> permute-direct-slots ] [ drop tail ] 3bi append ; + +: change-tuple ( tuple quot -- newtuple ) + >r tuple>array r> call >tuple ; inline + +: update-tuples ( predicate n permutation -- ) + [ permute-all-slots ] 2curry [ change-tuple ] curry + >r "predicate" word-prop instances dup r> map + become ; inline + +: update-tuples-after ( class superclass newslots -- ) + [ 2drop ] [ slot-permutation ] 3bi + [ update-tuples ] 3curry after-compilation ; : define-new-tuple-class ( class superclass slots -- ) [ drop f tuple-class define-class ] - [ nip define-tuple-slots ] [ + [ nip "slot-names" set-word-prop ] [ 2drop class-usages keys [ tuple-class? ] subset [ + [ define-tuple-slots ] [ define-tuple-layout ] [ define-tuple-predicate ] - bi + tri ] each ] 3tri ; : redefine-tuple-class ( class superclass slots -- ) - [ reshape-tuples ] + [ update-tuples-after ] [ nip - [ forget-slots ] + [ forget-removed-slots ] [ drop changed-word ] [ drop redefined ] 2tri @@ -175,7 +196,7 @@ M: tuple-class define-tuple-class 3drop ; : define-error-class ( class superclass slots -- ) - pick >r define-tuple-class r> + [ define-tuple-class ] [ 2drop ] 3bi dup [ construct-boa throw ] curry define ; M: tuple clone @@ -196,8 +217,6 @@ M: tuple hashcode* ] 2curry reduce ] recursive-hashcode ; -: tuple-slots ( tuple -- seq ) tuple>array 2 tail ; - ! Definition protocol M: tuple-class reset-class { "metaclass" "superclass" "slots" "layout" } reset-props ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index dfd5c1b32a..eeb0926308 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -23,9 +23,6 @@ C: slot-spec [ drop ] [ 1array , \ declare , ] if ] [ ] make ; -: slot-named ( name specs -- spec/f ) - [ slot-spec-name = ] with find nip ; - : create-accessor ( name effect -- word ) >r "accessors" create dup r> "declared-effect" set-word-prop ; From c30a8a68ee6216b3140836e9f77c7306f48a5111 Mon Sep 17 00:00:00 2001 From: erg Date: Sun, 30 Mar 2008 18:22:35 -0500 Subject: [PATCH 328/886] refactor mersenne-twister to not use new-effects --- .../mersenne-twister/mersenne-twister.factor | 38 ++++++++++--------- 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index ad9dae51ae..4c4bc8286f 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -4,11 +4,14 @@ ! 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 new-effects random ; +accessors math.ranges random ; IN: random.mersenne-twister r over r> [ curry ] 2bi@ ; + TUPLE: mersenne-twister seq i ; : mt-n 624 ; inline @@ -19,34 +22,33 @@ TUPLE: mersenne-twister seq i ; : wrap ( x n -- y ) 2dup >= [ - ] [ drop ] if ; inline : mt-wrap ( x -- y ) mt-n wrap ; inline -: set-generated ( mt y from-elt to -- ) - >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi - r> bitxor bitxor r> new-set-nth drop ; inline +: set-generated ( y from-elt to seq -- ) + >r >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi + r> bitxor bitxor r> r> set-nth ; inline -: calculate-y ( mt y1 y2 -- y ) - >r over r> - [ new-nth mt-hi ] [ new-nth mt-lo ] 2bi* bitor ; inline +: calculate-y ( y1 y2 mt -- y ) + [ nth mt-hi ] [ nth mt-lo ] curry2 bi* bitor ; inline -: (mt-generate) ( mt-seq n -- y to from-elt ) - [ dup 1+ mt-wrap calculate-y ] - [ mt-m + mt-wrap new-nth ] - [ nip ] 2tri ; +: (mt-generate) ( n mt-seq -- y to from-elt ) + [ >r dup 1+ mt-wrap r> calculate-y ] + [ >r mt-m + mt-wrap r> nth ] + [ drop ] 2tri ; : mt-generate ( mt -- ) - [ seq>> mt-n [ dupd (mt-generate) set-generated ] with each ] + [ >r mt-n r> seq>> [ [ (mt-generate) ] keep set-generated ] curry each ] [ 0 >>i drop ] bi ; : init-mt-first ( seed -- seq ) >r mt-n 0 r> - HEX: ffffffff bitand 0 new-set-nth ; + HEX: ffffffff bitand 0 pick set-nth ; : init-mt-formula ( seq i -- f(seq[i]) ) - tuck new-nth dup -30 shift bitxor 1812433253 * + + tuck swap nth dup -30 shift bitxor 1812433253 * + 1+ HEX: ffffffff bitand ; : init-mt-rest ( seq -- ) mt-n 1- [0,b) [ - dupd [ init-mt-formula ] keep 1+ new-set-nth drop + dupd [ init-mt-formula ] keep 1+ rot set-nth ] with each ; : init-mt-seq ( seed -- seq ) @@ -68,7 +70,7 @@ M: mersenne-twister seed-random ( mt seed -- ) init-mt-seq >>seq drop ; M: mersenne-twister random-32* ( mt -- r ) - dup [ seq>> ] [ i>> ] bi - dup mt-n < [ drop 0 pick mt-generate ] unless - new-nth mt-temper + dup [ i>> ] [ seq>> ] bi + over mt-n < [ nip >r dup mt-generate 0 r> ] unless + nth mt-temper swap [ 1+ ] change-i drop ; From 55a69392faadff0988a49696f734562491e484d0 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 31 Mar 2008 13:52:42 +1300 Subject: [PATCH 329/886] First cut at variables in ebnf --- extra/peg/ebnf/ebnf.factor | 28 ++++++++++++++++++++++------ 1 file changed, 22 insertions(+), 6 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 41b5a1b655..e9ec0dc4e2 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -3,7 +3,7 @@ USING: kernel compiler.units parser words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg peg.parsers unicode.categories multiline combinators.lib - splitting accessors effects ; + splitting accessors effects sequences.deep ; IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; @@ -227,15 +227,17 @@ GENERIC: (transform) ( ast -- parser ) SYMBOL: parser SYMBOL: main +SYMBOL: vars : transform ( ast -- object ) - H{ } clone dup dup [ parser set swap (transform) main set ] bind ; + H{ } clone dup dup [ parser set V{ } vars set swap (transform) main set ] bind ; M: ebnf (transform) ( ast -- parser ) rules>> [ (transform) ] map peek ; M: ebnf-rule (transform) ( ast -- parser ) - dup elements>> (transform) [ + dup elements>> + vars get clone vars [ (transform) ] with-variable [ swap symbol>> set ] keep ; @@ -270,12 +272,26 @@ M: ebnf-repeat1 (transform) ( ast -- parser ) M: ebnf-optional (transform) ( ast -- parser ) transform-group optional ; +: build-locals ( string vars -- string ) + dup empty? [ + drop + ] [ + [ + "[let* | " % + [ dup % " [ \"" % % "\" get ] " % ] each + " | " % + % + " ] with-locals" % + ] "" make + ] if ; + M: ebnf-action (transform) ( ast -- parser ) [ parser>> (transform) ] keep - code>> string-lines [ parse-lines ] with-compilation-unit action ; + code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit action ; M: ebnf-var (transform) ( ast -- parser ) - parser>> (transform) ; + [ parser>> (transform) ] [ name>> ] bi + dup vars get push [ dupd set ] curry action ; M: ebnf-terminal (transform) ( ast -- parser ) symbol>> token sp ; @@ -303,7 +319,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) : ebnf>quot ( string -- hashtable quot ) 'ebnf' parse check-parse-result parse-result-ast transform dup dup parser [ main swap at compile ] with-variable - [ compiled-parse ] curry ; + [ compiled-parse ] curry [ with-scope ] curry ; : [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing From a098790634503dfc03eb24969a4fbaff7f7512f5 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 30 Mar 2008 17:58:47 -0700 Subject: [PATCH 330/886] Updated extra/match to use bi@ instead of 2apply. Ran "peg" test for testing. --- extra/match/match.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/match/match.factor b/extra/match/match.factor index dbc42f53e3..825d58c7c2 100755 --- a/extra/match/match.factor +++ b/extra/match/match.factor @@ -70,7 +70,7 @@ MACRO: match-cond ( assoc -- ) dup length zero? not [ 1 tail ] [ drop f ] if ; : (match-first) ( seq pattern-seq -- bindings leftover/f ) - 2dup [ length ] 2apply < [ 2drop f f ] + 2dup [ length ] bi@ < [ 2drop f f ] [ 2dup length head over match [ nip swap ?1-tail ] [ >r 1 tail r> (match-first) ] if* From ee2194d1dc1eb4df9072dae9ce50a9bb13353b98 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 31 Mar 2008 14:03:16 +1300 Subject: [PATCH 331/886] Allow variable names on elements --- extra/peg/ebnf/ebnf.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index e9ec0dc4e2..f98b08093a 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -102,7 +102,7 @@ C: ebnf "]" syntax , ] seq* [ first >string ] action ; -: 'element' ( -- parser ) +: ('element') ( -- parser ) #! An element of a rule. It can be a terminal or a #! non-terminal but must not be followed by a "=". #! The latter indicates that it is the beginning of a @@ -120,6 +120,12 @@ C: ebnf ] choice* , ] seq* [ first ] action ; +: 'element' ( -- parser ) + [ + [ ('element') , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 ] action , + ('element') , + ] choice* ; + DEFER: 'choice' : grouped ( quot suffix -- parser ) From 729ac1d6dc18ddfd26aebae44d27c6ea62eec767 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 31 Mar 2008 14:59:22 +1300 Subject: [PATCH 332/886] Some ebnf tweaks and tests to do with variables --- extra/peg/ebnf/ebnf-tests.factor | 9 ++++++++- extra/peg/ebnf/ebnf.factor | 2 +- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 7aa61e84da..cf16fad2cd 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel tools.test peg peg.ebnf words ; +USING: kernel tools.test peg peg.ebnf words math math.parser ; IN: peg.ebnf.tests { T{ ebnf-non-terminal f "abc" } } [ @@ -160,6 +160,13 @@ IN: peg.ebnf.tests "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 { V{ V{ 49 } "+" V{ 49 } } } [ #! Test direct left recursion. diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index f98b08093a..74b3e3540d 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -283,7 +283,7 @@ M: ebnf-optional (transform) ( ast -- parser ) drop ] [ [ - "[let* | " % + "USING: locals namespaces ; [let* | " % [ dup % " [ \"" % % "\" get ] " % ] each " | " % % From c45eba68987e41ad14e0cc817079801e713af1b8 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 31 Mar 2008 16:34:59 +1300 Subject: [PATCH 333/886] Add semantic parser --- extra/peg/peg-docs.factor | 13 +++++++++++++ extra/peg/peg.factor | 20 ++++++++++++++++++++ 2 files changed, 33 insertions(+) diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index e7bd255569..c54a39b7b0 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -95,6 +95,19 @@ HELP: optional "Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is " "'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ; +HELP: semantic +{ $values + { "parser" "a parser" } + { "quot" "a quotation with stack effect ( object -- bool )" } +} +{ $description + "Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with " + "the AST produced by 'p1' on the stack returns true." } +{ $examples + { $example "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse" "f" } + { $example "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast " "67" } +} ; + HELP: ensure { $values { "parser" "a parser" } diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 43eb9e8d9e..9e35c5b9be 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -414,6 +414,23 @@ TUPLE: optional-parser p1 ; M: optional-parser (compile) ( parser -- quot ) p1>> compiled-parser \ ?quot optional-pattern match-replace ; +TUPLE: semantic-parser p1 quot ; + +MATCH-VARS: ?parser ; + +: semantic-pattern ( -- quot ) + [ + ?parser [ + dup parse-result-ast ?quot call [ drop f ] unless + ] [ + f + ] if* + ] ; + +M: semantic-parser (compile) ( parser -- quot ) + [ p1>> compiled-parser ] [ quot>> ] bi + 2array { ?parser ?quot } semantic-pattern match-replace ; + TUPLE: ensure-parser p1 ; : ensure-pattern ( -- quot ) @@ -546,6 +563,9 @@ PRIVATE> : optional ( parser -- parser ) optional-parser construct-boa init-parser ; +: semantic ( parser quot -- parser ) + semantic-parser construct-boa init-parser ; + : ensure ( parser -- parser ) ensure-parser construct-boa init-parser ; From 8aa676ab1eda35b0d6011fbbb2689e12215664f7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 22:42:36 -0500 Subject: [PATCH 334/886] Documentation fixes --- core/continuations/continuations-docs.factor | 1 + core/debugger/debugger-docs.factor | 10 +++++++++- extra/help/handbook/handbook.factor | 1 + extra/help/markup/markup.factor | 3 +-- 4 files changed, 12 insertions(+), 3 deletions(-) diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 7209b7ec4d..ca7af930f2 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -29,6 +29,7 @@ $nl { $subsection ignore-errors } "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" } "When Factor encouters a critical error, it calls the following word:" { $subsection die } ; diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor index 5e8b6df34a..f8b53d4abc 100755 --- a/core/debugger/debugger-docs.factor +++ b/core/debugger/debugger-docs.factor @@ -86,7 +86,15 @@ HELP: error-hook 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." } diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 912c3c35f3..1c2dfde85c 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -206,6 +206,7 @@ ARTICLE: "tools" "Developer tools" { $subsection "tools.vocabs" } "Exploratory tools:" { $subsection "editor" } +{ $subsection "listener" } { $subsection "tools.crossref" } { $subsection "inspector" } "Debugging tools:" diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 5dc7255eed..f8d360fd0a 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -138,8 +138,7 @@ M: f print-element drop ; 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) ; From f66774e87564aa5f6d66f80dd00c72b2db456700 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 31 Mar 2008 16:50:05 +1300 Subject: [PATCH 335/886] Add tests for semantic and add syntax for it to ebnf Syntax is ?[ ...]? For example: [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] { 1 2 3 4 5 6 } swap call . --- extra/peg/ebnf/ebnf-tests.factor | 12 ++++++++++++ extra/peg/ebnf/ebnf.factor | 16 ++++++++++++---- extra/peg/peg-tests.factor | 13 +++++++++++-- 3 files changed, 35 insertions(+), 6 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index cf16fad2cd..4f802c5207 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -168,6 +168,18 @@ IN: peg.ebnf.tests "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 + { V{ V{ 49 } "+" V{ 49 } } } [ #! Test direct left recursion. #! Using packrat, so first part of expr fails, causing 2nd choice to be used diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 74b3e3540d..4f00edbd3c 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -20,6 +20,7 @@ TUPLE: ebnf-optional group ; TUPLE: ebnf-rule symbol elements ; TUPLE: ebnf-action parser code ; TUPLE: ebnf-var parser name ; +TUPLE: ebnf-semantic parser code ; TUPLE: ebnf rules ; C: ebnf-non-terminal @@ -36,6 +37,7 @@ C: ebnf-optional C: ebnf-rule C: ebnf-action C: ebnf-var +C: ebnf-semantic C: ebnf : syntax ( string -- parser ) @@ -156,6 +158,7 @@ DEFER: 'choice' : 'factor-code' ( -- parser ) [ "]]" token ensure-not , + "]?" token ensure-not , [ drop t ] satisfy , ] seq* [ first ] action repeat0 [ >string ] action ; @@ -193,14 +196,15 @@ DEFER: 'choice' : 'action' ( -- parser ) "[[" 'factor-code' "]]" syntax-pack ; +: 'semantic' ( -- parser ) + "?[" 'factor-code' "]?" syntax-pack ; + : 'sequence' ( -- parser ) #! A sequence of terminals and non-terminals, including #! groupings of those. [ - [ - ('sequence') , - 'action' , - ] seq* [ first2 ] action , + [ ('sequence') , 'action' , ] seq* [ first2 ] action , + [ ('sequence') , 'semantic' , ] seq* [ first2 ] action , ('sequence') , ] choice* repeat1 [ dup length 1 = [ first ] [ ] if @@ -295,6 +299,10 @@ M: ebnf-action (transform) ( ast -- parser ) [ parser>> (transform) ] keep code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit action ; +M: ebnf-semantic (transform) ( ast -- parser ) + [ parser>> (transform) ] keep + code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit semantic ; + M: ebnf-var (transform) ( ast -- parser ) [ parser>> (transform) ] [ name>> ] bi dup vars get push [ dupd set ] curry action ; diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index f57fe83220..fcec33f7c2 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -1,7 +1,7 @@ ! 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 accessors words ; +USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words math ; IN: peg.tests { f } [ @@ -182,4 +182,13 @@ IN: peg.tests [ f , "a" token , ] seq* dup parsers>> dupd 0 swap set-nth compile word? -] unit-test \ No newline at end of file +] 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 + From a41f8ef7338d565329ca8d0cb646e3746032ccd2 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 31 Mar 2008 17:26:42 +1300 Subject: [PATCH 336/886] Mention how to fail from action in pegs --- extra/peg/peg-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index c54a39b7b0..5f200be78e 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -137,7 +137,7 @@ HELP: action "Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting " "from that parse. The result of the quotation is then used as the final AST. This can be used " "for manipulating the parse tree to produce a AST better suited for the task at hand rather than " - "the default AST." } + "the default AST. If the quotation returns " { $link fail } " then the parser fails." } { $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ; HELP: sp From d87667f903c3dd33fda10e5cc8a74fc3cc0e02de Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 23:54:57 -0500 Subject: [PATCH 337/886] Add inline declaration --- extra/random/mersenne-twister/mersenne-twister.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index 4c4bc8286f..ce1749ce62 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -10,7 +10,7 @@ IN: random.mersenne-twister r over r> [ curry ] 2bi@ ; + >r over r> [ curry ] 2bi@ ; inline TUPLE: mersenne-twister seq i ; From 2ebb7d22718b1b1e90943c5fd35a6a4915fb4e34 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 31 Mar 2008 01:19:21 -0500 Subject: [PATCH 338/886] Clean up bootstrap code a bit --- core/bootstrap/image/image.factor | 116 ++++++++++++++---------------- core/bootstrap/primitives.factor | 49 +++++++------ 2 files changed, 84 insertions(+), 81 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index deb54fdeeb..5d49203554 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -12,7 +12,7 @@ io.encodings.binary ; IN: bootstrap.image : my-arch ( -- arch ) - cpu dup "ppc" = [ os "-" rot 3append ] when ; + cpu dup "ppc" = [ >r os "-" r> 3append ] when ; : boot-image-name ( arch -- string ) "boot." swap ".image" 3append ; @@ -55,7 +55,7 @@ IN: bootstrap.image : 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 @@ -134,10 +134,10 @@ SYMBOL: undefined-quot : 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 ; @@ -164,7 +164,7 @@ GENERIC: ' ( obj -- ptr ) userenv-size [ f ' emit ] times ; : emit-userenv ( symbol -- ) - dup get ' swap userenv-offset fixup ; + [ get ' ] [ userenv-offset ] bi fixup ; ! Bignums @@ -175,14 +175,15 @@ GENERIC: ' ( obj -- ptr ) : 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 ; @@ -221,28 +222,33 @@ M: f ' ! 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 @@ -285,9 +291,10 @@ M: string ' 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 ; @@ -296,29 +303,28 @@ M: bit-array ' bit-array emit-dummy-array ; M: float-array ' float-array emit-dummy-array ; ! Tuples +: (emit-tuple) ( tuple -- pointer ) + [ tuple>array 1 tail-slice ] + [ class transfer-word tuple-layout ] bi add* [ ' ] map + tuple type-number dup [ emit-seq ] emit-object ; + : emit-tuple ( tuple -- pointer ) - [ - [ - dup class transfer-word tuple-layout ' , - tuple>array 1 tail-slice [ ' ] map % - ] { } make - tuple type-number dup [ emit-seq ] emit-object - ] - ! Hack - over class word-name "tombstone" = - [ objects get swap cache ] [ call ] if ; + dup class word-name "tombstone" = + [ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ; M: tuple ' emit-tuple ; M: tuple-layout ' objects get [ [ - dup layout-hashcode ' , - dup layout-class ' , - dup layout-size ' , - dup layout-superclasses ' , - layout-echelon ' , - ] { } make + { + [ 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 ; @@ -329,14 +335,9 @@ M: tombstone ' word-def first objects get [ emit-tuple ] cache ; ! Arrays -: emit-array ( list type tag -- pointer ) - >r >r [ ' ] map r> r> [ - dup length emit-fixnum - emit-seq - ] emit-object ; - 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 @@ -351,13 +352,6 @@ M: quotation ' ] 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 ( -- ) @@ -437,8 +431,8 @@ M: curry ' : write-image ( image -- ) "Writing image to " write architecture get boot-image-name resource-path - dup write "..." print flush - binary [ (write-image) ] with-stream ; + [ write "..." print flush ] + [ binary [ (write-image) ] with-stream ] bi ; PRIVATE> diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 2e1a7f9f57..bc876c2dec 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -5,7 +5,8 @@ hashtables.private io kernel math namespaces parser sequences strings vectors words quotations assocs layouts classes classes.tuple classes.tuple.private kernel.private vocabs vocabs.loader source-files definitions slots.deprecated -classes.union compiler.units bootstrap.image.private io.files ; +classes.union compiler.units bootstrap.image.private io.files +accessors combinators ; IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush @@ -102,33 +103,36 @@ num-types get f builtins set ! Builtin classes : builtin-predicate-quot ( class -- quot ) [ - "type" word-prop dup - \ tag-mask get < \ tag \ type ? , , \ eq? , + "type" word-prop + [ tag-mask get < \ tag \ type ? , ] [ , ] bi + \ eq? , ] [ ] make ; : define-builtin-predicate ( class -- ) - dup - dup builtin-predicate-quot define-predicate - predicate-word make-inline ; + [ dup builtin-predicate-quot define-predicate ] + [ predicate-word make-inline ] + bi ; : 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 ] + bi ; : 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 + { + [ register-builtin ] + [ f f builtin-class define-class ] + [ define-builtin-predicate ] + [ ] + } cleave r> define-builtin-slots ; ! Forward definitions @@ -335,7 +339,10 @@ define-builtin { "set-delegate" "kernel" } } } -define-tuple-slots +[ drop ] [ generate-tuple-slots ] 2bi +[ [ name>> ] map "slot-names" set-word-prop ] +[ "slots" set-word-prop ] +[ define-slots ] 2tri "tuple" "kernel" lookup define-tuple-layout @@ -495,8 +502,9 @@ f builtins get num-tags get tail union-class define-class } define-tuple-class "curry" "kernel" lookup -dup f "inline" set-word-prop -dup tuple-layout [ ] curry define +[ f "inline" set-word-prop ] +[ ] +[ tuple-layout [ ] curry ] tri define "compose" "kernel" create "tuple" "kernel" lookup @@ -515,8 +523,9 @@ dup tuple-layout [ ] curry define } define-tuple-class "compose" "kernel" lookup -dup f "inline" set-word-prop -dup tuple-layout [ ] curry define +[ f "inline" set-word-prop ] +[ ] +[ tuple-layout [ ] curry ] tri define ! Primitive words : make-primitive ( word vocab n -- ) From 6995e2adf5535194440fe5cac34087da2efda99e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 31 Mar 2008 01:19:34 -0500 Subject: [PATCH 339/886] Tuple reshaping now works with inheritance --- core/classes/tuple/tuple-docs.factor | 14 +---- core/classes/tuple/tuple-tests.factor | 88 +++++++++++++++++++++++--- core/classes/tuple/tuple.factor | 90 ++++++++++++++++----------- core/compiler/units/units.factor | 14 ++--- core/slots/slots.factor | 3 + 5 files changed, 142 insertions(+), 67 deletions(-) diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 7123d5c7c8..18c8143654 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -153,23 +153,11 @@ HELP: tuple= { $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: 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 } { "superclass" class } { "newslots" "a sequence of strings" } } -{ $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ; - HELP: removed-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 +HELP: forget-removed-slots { $values { "class" tuple-class } { "slots" "a sequence of strings" } } { $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 9b8228155b..0fac0c3779 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -265,9 +265,13 @@ C: laptop [ t ] [ "laptop" get computer? ] unit-test [ t ] [ "laptop" get tuple? ] 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 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 @@ -294,9 +298,13 @@ C: server [ t ] [ "server" get computer? ] unit-test [ t ] [ "server" get tuple? ] unit-test -[ "PowerPC" ] [ "server" get cpu>> ] unit-test -[ 64 ] [ "server" get ram>> ] unit-test -[ "1U" ] [ "server" get rackmount>> ] 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 @@ -316,10 +324,10 @@ C: server "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval ] must-fail -! Reshaping with inheritance +! Dynamically changing inheritance hierarchy TUPLE: electronic-device ; -[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device ;" eval ] unit-test +[ ] [ "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 @@ -335,11 +343,73 @@ TUPLE: electronic-device ; [ f ] [ "server" get laptop? ] unit-test [ t ] [ "server" get server? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: computer ;" eval ] 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 ; + +T{ test2 f "a" "b" } "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 + ! Redefinition problem TUPLE: redefinition-problem ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 401a421c51..158ea9fc55 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -24,13 +24,14 @@ M: 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 first -- array ) - [ array-nth ] curry map r> add* ; +: copy-tuple-slots ( n tuple -- array ) + [ array-nth ] curry map ; PRIVATE> @@ -128,48 +129,63 @@ PRIVATE> [ writer-word forget-method ] 2bi ] with each ; -: permutation ( seq1 seq2 -- permutation ) - swap [ index ] curry map ; - : all-slot-names ( class -- slots ) superclasses [ slot-names ] map concat \ class add* ; -: slot-permutation ( class superclass newslots -- n permutation ) - [ all-slot-names ] [ all-slot-names ] [ ] tri* append - [ drop length ] [ permutation ] 2bi ; +: compute-slot-permutation ( class old-slot-names -- permutation ) + >r all-slot-names r> [ index ] curry map ; -: permute-direct-slots ( oldslots permutation -- newslots ) +: apply-slot-permutation ( old-values permutation -- new-values ) [ [ swap ?nth ] [ drop f ] if* ] with map ; -: permute-all-slots ( oldslots n permutation -- newslots ) - [ >r head r> permute-direct-slots ] [ drop tail ] 3bi append ; +: 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-tuples ( predicate n permutation -- ) - [ permute-all-slots ] 2curry [ change-tuple ] curry - >r "predicate" word-prop instances dup r> map - become ; inline +: update-tuple ( tuple -- newtuple ) + [ permute-slots ] change-tuple ; -: update-tuples-after ( class superclass newslots -- ) - [ 2drop ] [ slot-permutation ] 3bi - [ update-tuples ] 3curry after-compilation ; +: 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 ; + +: subclasses ( class -- classes ) + class-usages keys [ tuple-class? ] subset ; + +: each-subclass ( class quot -- ) + >r subclasses r> each ; inline + +: define-tuple-shape ( class -- ) + [ define-tuple-slots ] + [ define-tuple-layout ] + [ define-tuple-predicate ] + tri ; : define-new-tuple-class ( class superclass slots -- ) [ drop f tuple-class define-class ] - [ nip "slot-names" set-word-prop ] [ + [ nip "slot-names" set-word-prop ] + [ 2drop - class-usages keys [ tuple-class? ] subset [ - [ define-tuple-slots ] - [ define-tuple-layout ] - [ define-tuple-predicate ] - tri - ] each + [ define-tuple-shape ] each-subclass ] 3tri ; : redefine-tuple-class ( class superclass slots -- ) - [ update-tuples-after ] + [ + 2drop + [ update-tuples-after ] each-subclass + ] [ nip [ forget-removed-slots ] @@ -205,11 +221,6 @@ M: tuple clone M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ; -: delegates ( obj -- seq ) - [ dup ] [ [ delegate ] keep ] [ ] unfold nip ; - -: is? ( obj quot -- ? ) >r delegates r> contains? ; inline - M: tuple hashcode* [ dup tuple-size -rot 0 -rot [ @@ -217,21 +228,26 @@ M: tuple hashcode* ] 2curry reduce ] recursive-hashcode ; -! Definition protocol M: tuple-class reset-class { "metaclass" "superclass" "slots" "layout" } reset-props ; M: object get-slots ( obj slots -- ... ) [ execute ] with each ; -M: object set-slots ( ... obj slots -- ) - get-slots ; - M: object construct-empty ( class -- tuple ) tuple-layout ; +M: object construct-boa ( ... class -- tuple ) + tuple-layout ; + +! Deprecated +M: object set-slots ( ... obj slots -- ) + get-slots ; + M: object construct ( ... slots class -- tuple ) construct-empty [ swap set-slots ] keep ; -M: object construct-boa ( ... class -- tuple ) - tuple-layout ; +: delegates ( obj -- seq ) + [ dup ] [ [ delegate ] keep ] [ ] unfold nip ; + +: is? ( obj quot -- ? ) >r delegates r> contains? ; inline diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 9849ddca7d..f87c1ec985 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -69,21 +69,19 @@ GENERIC: definitions-changed ( assoc obj -- ) dup [ drop 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 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 + call-update-tuples-hook dup [ drop crossref? ] assoc-contains? modify-code-heap changed-definitions notify-definition-observers ; @@ -91,7 +89,7 @@ SYMBOL: post-compile-tasks [ H{ } clone changed-words set H{ } clone forgotten-definitions set - V{ } clone post-compile-tasks set + H{ } clone outdated-tuples set new-definitions set old-definitions set [ finish-compilation-unit ] diff --git a/core/slots/slots.factor b/core/slots/slots.factor index eeb0926308..b674ec8c2a 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -79,3 +79,6 @@ C: slot-spec 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 ; From 75497d721219261a7b45a47f018d6314d2fe533a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 31 Mar 2008 01:26:09 -0500 Subject: [PATCH 340/886] Add another unit test --- core/classes/tuple/tuple-tests.factor | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 0fac0c3779..950650dbf0 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -410,6 +410,14 @@ test-a/b 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 + ! Redefinition problem TUPLE: redefinition-problem ; From 30a7238f71fa930b46fceea9024fc1e9cbceef2a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 31 Mar 2008 02:30:06 -0500 Subject: [PATCH 341/886] Clean up serialization --- extra/serialize/serialize.factor | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index ac247057f4..7a2fbfae9e 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -90,13 +90,13 @@ M: float (serialize) ( obj -- ) 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 -- ) [ @@ -120,7 +120,8 @@ M: array (serialize) ( obj -- ) 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 -- ) @@ -234,10 +235,12 @@ SYMBOL: deserialized ] 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) ; From 8f0530daa6f8ce5a71dbea6f9edf081229301dc8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 31 Mar 2008 03:40:27 -0500 Subject: [PATCH 342/886] More inheritance fixes --- core/classes/tuple/tuple-tests.factor | 44 ++++++++++++++++++++++++++- core/classes/tuple/tuple.factor | 15 +++++---- 2 files changed, 50 insertions(+), 9 deletions(-) diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 950650dbf0..db0e25f091 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -3,7 +3,7 @@ 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 ; +calendar prettyprint io.streams.string splitting inspector ; IN: classes.tuple.tests TUPLE: rect x y w h ; @@ -418,6 +418,48 @@ test-a/b 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 + +{ 3 1 } [ ] must-infer-as + +[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test + +{ 5 1 } [ ] must-infer-as + +[ { f 1 2 3 4 5 } ] [ 1 2 3 4 5 tuple-slots ] unit-test + ! Redefinition problem TUPLE: redefinition-problem ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 158ea9fc55..a3d0238d1c 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -184,15 +184,14 @@ PRIVATE> : redefine-tuple-class ( class superclass slots -- ) [ 2drop - [ update-tuples-after ] each-subclass - ] - [ - nip - [ forget-removed-slots ] - [ drop changed-word ] - [ drop redefined ] - 2tri + [ + [ update-tuples-after ] + [ changed-word ] + [ redefined ] + tri + ] each-subclass ] + [ nip forget-removed-slots ] [ define-new-tuple-class ] 3tri ; From 23bdf2faa7ac92bd433671539e5153166839122c Mon Sep 17 00:00:00 2001 From: sheeple Date: Mon, 31 Mar 2008 08:57:16 -0500 Subject: [PATCH 343/886] add using --- extra/io/unix/sockets/sockets.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index dea7dc17b5..c7931c6f0c 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -7,7 +7,7 @@ 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 ; +combinators io.backend ; IN: io.unix.sockets : pending-init-error ( port -- ) From b21d83b53130a87f6adc9498cf06c086081ce260 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 31 Mar 2008 12:47:39 -0500 Subject: [PATCH 344/886] remove failing unit test for now --- extra/openssl/openssl-tests.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor index c689f729d1..c85c0ee218 100755 --- a/extra/openssl/openssl-tests.factor +++ b/extra/openssl/openssl-tests.factor @@ -11,11 +11,12 @@ namespaces math math.parser openssl prettyprint sequences tools.test ; ] [ "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 From 13b31be060071a645bdef5ed61e258d6173e93a6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 31 Mar 2008 13:43:42 -0500 Subject: [PATCH 345/886] fix copy-tree --- core/io/files/files.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 458a9145a6..f397af606b 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -4,6 +4,7 @@ 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 init accessors ; +USE: tools.walker IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) @@ -267,6 +268,7 @@ M: object copy-file DEFER: copy-tree-into : copy-tree ( from to -- ) + normalize-pathname over link-info type>> { { +symbolic-link+ [ copy-link ] } From b13ac1e17f323f826669f6758a90453940e4cbb5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 31 Mar 2008 13:51:24 -0500 Subject: [PATCH 346/886] remove using --- core/io/files/files.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index f397af606b..099acb157e 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -4,7 +4,6 @@ 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 init accessors ; -USE: tools.walker IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) From a8e223f47143bf193d5df8f7b3bfe2308c7cb574 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 31 Mar 2008 13:51:34 -0500 Subject: [PATCH 347/886] fix unix domain socket test --- extra/io/sockets/sockets.factor | 3 ++- extra/io/unix/sockets/sockets.factor | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 1dc7f4883d..e1cc36cd2e 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -6,7 +6,8 @@ IN: io.sockets TUPLE: local path ; -C: local +: ( path -- addrspec ) + normalize-pathname local construct-boa ; TUPLE: inet4 host port ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index c7931c6f0c..69ce6a3069 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -7,7 +7,7 @@ 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 io.backend ; +combinators io.backend io.files ; IN: io.unix.sockets : pending-init-error ( port -- ) @@ -189,7 +189,7 @@ M: local protocol-family drop PF_UNIX ; M: local sockaddr-type drop "sockaddr-un" c-type ; M: local make-sockaddr - local-path normalize-pathname + local-path cwd prepend-path dup length 1 + max-un-path > [ "Path too long" throw ] when "sockaddr-un" AF_UNIX over set-sockaddr-un-family From 0a63a8fb40dd290b36958bad7cda4b2751b961c6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 31 Mar 2008 14:38:11 -0500 Subject: [PATCH 348/886] normalize-pathname in local sockets --- extra/io/unix/sockets/sockets.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index bd7dfd9ce1..dea7dc17b5 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -189,7 +189,7 @@ M: local protocol-family drop PF_UNIX ; M: local sockaddr-type drop "sockaddr-un" c-type ; M: local make-sockaddr - local-path + local-path normalize-pathname dup length 1 + max-un-path > [ "Path too long" throw ] when "sockaddr-un" AF_UNIX over set-sockaddr-un-family From f49c72bb05fd5a2af16622f20b6771a857b10fac Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 31 Mar 2008 15:31:51 -0500 Subject: [PATCH 349/886] remove curry2 from mersenne.private... --- extra/random/mersenne-twister/mersenne-twister.factor | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index ce1749ce62..8ddbdac6f4 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -9,9 +9,6 @@ IN: random.mersenne-twister r over r> [ curry ] 2bi@ ; inline - TUPLE: mersenne-twister seq i ; : mt-n 624 ; inline @@ -27,7 +24,7 @@ TUPLE: mersenne-twister seq i ; r> bitxor bitxor r> r> set-nth ; inline : calculate-y ( y1 y2 mt -- y ) - [ nth mt-hi ] [ nth mt-lo ] curry2 bi* bitor ; inline + tuck [ nth mt-hi ] [ nth mt-lo ] 2bi* bitor ; inline : (mt-generate) ( n mt-seq -- y to from-elt ) [ >r dup 1+ mt-wrap r> calculate-y ] From c2fdd797bcbff592ac1a65cba2044d7f8aef719f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 31 Mar 2008 16:20:09 -0500 Subject: [PATCH 350/886] Try to fix inotify again --- extra/io/unix/linux/linux.factor | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 7580e7bf6b..3a8fad3d4d 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -3,8 +3,8 @@ 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 ; +namespaces threads continuations init math alien.c-types alien +vocabs.loader accessors ; IN: io.unix.linux TUPLE: linux-io ; @@ -18,18 +18,16 @@ TUPLE: linux-monitor ; TUPLE: inotify watches ; -: watches ( -- assoc ) inotify get-global inotify-watches ; +: watches ( -- assoc ) inotify get-global watches>> ; : wd>monitor ( wd -- monitor ) watches at ; : ( -- port/f ) H{ } clone - inotify_init dup 0 < [ 2drop f ] [ - inotify - { set-inotify-watches set-delegate } inotify construct - ] if ; + inotify_init [ io-error ] [ inotify ] bi + { set-inotify-watches set-delegate } inotify construct ; -: inotify-fd inotify get-global port-handle ; +: inotify-fd inotify get-global handle>> ; : (add-watch) ( path mask -- wd ) inotify-fd -rot inotify_add_watch dup io-error ; @@ -80,10 +78,10 @@ M: linux-monitor dispose ( monitor -- ) parse-action swap alien>char-string ; : events-exhausted? ( i buffer -- ? ) - buffer-fill >= ; + fill>> >= ; : inotify-event@ ( i buffer -- alien ) - buffer-ptr ; + ptr>> ; : next-event ( i buffer -- i buffer ) 2dup inotify-event@ @@ -111,14 +109,17 @@ TUPLE: inotify-task ; f inotify-task ; : init-inotify ( mx -- ) - dup inotify set-global + + dup inotify set-global swap register-io-task ; M: inotify-task do-io-task ( task -- ) io-task-port read-notifications f ; M: linux-io init-io ( -- ) - dup mx set-global init-inotify ; + + [ mx set-global ] + [ [ init-inotify ] ignore-errors ] bi ; T{ linux-io } set-io-backend From 8742c3f2dcb95f5e6efcdf9ac94e52819096b1e0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 31 Mar 2008 16:20:22 -0500 Subject: [PATCH 351/886] Oops --- extra/io/unix/linux/linux.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 3a8fad3d4d..2ae4065fb6 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -119,7 +119,7 @@ M: inotify-task do-io-task ( task -- ) M: linux-io init-io ( -- ) [ mx set-global ] - [ [ init-inotify ] ignore-errors ] bi ; + [ [ init-inotify ] curry ignore-errors ] bi ; T{ linux-io } set-io-backend From ecf59b716844aa429e51be4dfcbc73c93bb44980 Mon Sep 17 00:00:00 2001 From: "U-CUTLER\\dharmatech" Date: Mon, 31 Mar 2008 15:27:32 -0600 Subject: [PATCH 352/886] Move ldap to unmaintained --- {extra => unmaintained}/ldap/authors.txt | 0 {extra => unmaintained}/ldap/conf/addentry.ldif | 0 {extra => unmaintained}/ldap/conf/createdit.ldif | 0 {extra => unmaintained}/ldap/conf/slapd.conf | 0 {extra => unmaintained}/ldap/ldap-tests.factor | 0 {extra => unmaintained}/ldap/ldap.factor | 0 {extra => unmaintained}/ldap/libldap/authors.txt | 0 {extra => unmaintained}/ldap/libldap/libldap.factor | 0 {extra => unmaintained}/ldap/libldap/tags.txt | 0 {extra => unmaintained}/ldap/summary.txt | 0 {extra => unmaintained}/ldap/tags.txt | 0 11 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/ldap/authors.txt (100%) rename {extra => unmaintained}/ldap/conf/addentry.ldif (100%) rename {extra => unmaintained}/ldap/conf/createdit.ldif (100%) rename {extra => unmaintained}/ldap/conf/slapd.conf (100%) rename {extra => unmaintained}/ldap/ldap-tests.factor (100%) rename {extra => unmaintained}/ldap/ldap.factor (100%) rename {extra => unmaintained}/ldap/libldap/authors.txt (100%) rename {extra => unmaintained}/ldap/libldap/libldap.factor (100%) rename {extra => unmaintained}/ldap/libldap/tags.txt (100%) rename {extra => unmaintained}/ldap/summary.txt (100%) rename {extra => unmaintained}/ldap/tags.txt (100%) diff --git a/extra/ldap/authors.txt b/unmaintained/ldap/authors.txt similarity index 100% rename from extra/ldap/authors.txt rename to unmaintained/ldap/authors.txt diff --git a/extra/ldap/conf/addentry.ldif b/unmaintained/ldap/conf/addentry.ldif similarity index 100% rename from extra/ldap/conf/addentry.ldif rename to unmaintained/ldap/conf/addentry.ldif diff --git a/extra/ldap/conf/createdit.ldif b/unmaintained/ldap/conf/createdit.ldif similarity index 100% rename from extra/ldap/conf/createdit.ldif rename to unmaintained/ldap/conf/createdit.ldif diff --git a/extra/ldap/conf/slapd.conf b/unmaintained/ldap/conf/slapd.conf similarity index 100% rename from extra/ldap/conf/slapd.conf rename to unmaintained/ldap/conf/slapd.conf diff --git a/extra/ldap/ldap-tests.factor b/unmaintained/ldap/ldap-tests.factor similarity index 100% rename from extra/ldap/ldap-tests.factor rename to unmaintained/ldap/ldap-tests.factor diff --git a/extra/ldap/ldap.factor b/unmaintained/ldap/ldap.factor similarity index 100% rename from extra/ldap/ldap.factor rename to unmaintained/ldap/ldap.factor diff --git a/extra/ldap/libldap/authors.txt b/unmaintained/ldap/libldap/authors.txt similarity index 100% rename from extra/ldap/libldap/authors.txt rename to unmaintained/ldap/libldap/authors.txt diff --git a/extra/ldap/libldap/libldap.factor b/unmaintained/ldap/libldap/libldap.factor similarity index 100% rename from extra/ldap/libldap/libldap.factor rename to unmaintained/ldap/libldap/libldap.factor diff --git a/extra/ldap/libldap/tags.txt b/unmaintained/ldap/libldap/tags.txt similarity index 100% rename from extra/ldap/libldap/tags.txt rename to unmaintained/ldap/libldap/tags.txt diff --git a/extra/ldap/summary.txt b/unmaintained/ldap/summary.txt similarity index 100% rename from extra/ldap/summary.txt rename to unmaintained/ldap/summary.txt diff --git a/extra/ldap/tags.txt b/unmaintained/ldap/tags.txt similarity index 100% rename from extra/ldap/tags.txt rename to unmaintained/ldap/tags.txt From 01d0ab20c67c8b6e240f0ceaa6092cfca55ef919 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 31 Mar 2008 15:28:21 -0600 Subject: [PATCH 353/886] sequences: new words: prefix and suffix --- core/sequences/sequences.factor | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 1f2a6c5501..26c1013c28 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -478,18 +478,31 @@ M: sequence <=> : push-new ( elt seq -- ) [ delete ] 2keep push ; +: add* ( seq elt -- newseq ) + over >r over length 1+ r> [ + [ 0 swap set-nth-unsafe ] keep + [ 1 swap copy ] keep + ] new-like ; + +: prefix ( seq elt -- newseq ) + over >r over length 1+ r> [ + [ 0 swap set-nth-unsafe ] keep + [ 1 swap copy ] keep + ] new-like ; + : 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 ) +: suffix ( seq elt -- newseq ) over >r over length 1+ r> [ - [ 0 swap set-nth-unsafe ] keep - [ 1 swap copy ] keep + [ >r over length r> set-nth-unsafe ] keep + [ 0 swap copy ] keep ] new-like ; + : seq-diff ( seq1 seq2 -- newseq ) swap [ member? not ] curry subset ; From 4181728ecaf15c2d6fcc8ea5b237a9354685b72a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 31 Mar 2008 15:29:22 -0600 Subject: [PATCH 354/886] ui.gadgets.slate: add some gesture handling for processing demos --- extra/ui/gadgets/slate/slate.factor | 104 +++++++++++++++++++++++++++- 1 file changed, 102 insertions(+), 2 deletions(-) diff --git a/extra/ui/gadgets/slate/slate.factor b/extra/ui/gadgets/slate/slate.factor index 5ea1ec20fa..ab2abeec5b 100644 --- a/extra/ui/gadgets/slate/slate.factor +++ b/extra/ui/gadgets/slate/slate.factor @@ -3,7 +3,11 @@ USING: kernel namespaces opengl ui.render ui.gadgets ; IN: ui.gadgets.slate -TUPLE: slate action dim graft ungraft ; +TUPLE: slate action dim graft ungraft + button-down + button-up + key-down + key-up ; : ( action -- slate ) slate construct-gadget @@ -19,4 +23,100 @@ M: slate draw-gadget* ( slate -- ) 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 From 72bfd57f308a6b2efe7c8b9697282eab00588856 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Tue, 1 Apr 2008 11:28:14 +1300 Subject: [PATCH 355/886] Make ebnf forgiving of whitespace at end of expression --- extra/peg/ebnf/ebnf.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 4f00edbd3c..26e5d68df8 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -320,7 +320,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) : check-parse-result ( result -- result ) dup [ - dup parse-result-remaining empty? [ + dup parse-result-remaining [ blank? ] trim empty? [ [ "Unable to fully parse EBNF. Left to parse was: " % parse-result-remaining % From aa40350aa76805e1aed683966647aaeea2d7ed28 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 31 Mar 2008 18:18:05 -0600 Subject: [PATCH 356/886] replace add* and add with prefix and suffix --- core/alien/c-types/c-types.factor | 12 ++++++------ core/alien/compiler/compiler.factor | 2 +- core/alien/structs/structs-docs.factor | 10 +++++----- core/alien/structs/structs.factor | 2 +- core/classes/algebra/algebra.factor | 8 ++++---- core/classes/classes.factor | 2 +- core/classes/mixin/mixin.factor | 2 +- core/classes/tuple/tuple.factor | 2 +- core/combinators/combinators.factor | 4 ++-- core/cpu/x86/assembler/assembler.factor | 2 +- core/cpu/x86/intrinsics/intrinsics.factor | 4 ++-- core/cpu/x86/sse2/sse2.factor | 4 ++-- core/generic/generic.factor | 2 +- core/generic/standard/standard.factor | 6 +++--- core/inference/backend/backend.factor | 6 +++--- core/inference/class/class.factor | 2 +- core/inference/dataflow/dataflow.factor | 2 +- core/inference/transforms/transforms.factor | 2 +- core/io/encodings/encodings.factor | 2 +- core/optimizer/known-words/known-words.factor | 2 +- core/optimizer/specializers/specializers.factor | 2 +- core/parser/parser.factor | 2 +- core/slots/slots.factor | 2 +- core/splitting/splitting.factor | 2 +- core/vocabs/loader/loader.factor | 2 +- core/vocabs/vocabs.factor | 2 +- extra/benchmark/fasta/fasta.factor | 2 +- extra/cfdg/cfdg.factor | 2 +- extra/color-picker/color-picker.factor | 2 +- extra/delegate/delegate.factor | 2 +- extra/editors/editors.factor | 2 +- extra/faq/faq.factor | 2 +- extra/fry/fry.factor | 2 +- extra/help/markup/markup.factor | 2 +- extra/koszul/koszul.factor | 4 ++-- extra/lazy-lists/lazy-lists.factor | 2 +- extra/locals/locals.factor | 8 ++++---- extra/logging/logging.factor | 2 +- extra/lsys/tortoise/graphics/graphics.factor | 2 +- extra/math/combinatorics/combinatorics.factor | 2 +- extra/multi-methods/multi-methods.factor | 4 ++-- extra/opengl/gl/extensions/extensions.factor | 2 +- extra/oracle/oracle.factor | 4 ++-- extra/parser-combinators/parser-combinators.factor | 6 +++--- extra/peg/peg.factor | 4 ++-- extra/project-euler/043/043.factor | 4 ++-- extra/project-euler/common/common.factor | 4 ++-- extra/qualified/qualified.factor | 2 +- extra/regexp/regexp.factor | 2 +- extra/regexp2/regexp2.factor | 2 +- extra/sequences/lib/lib.factor | 2 +- extra/springies/springies.factor | 4 ++-- extra/state-machine/state-machine.factor | 2 +- extra/tetris/board/board.factor | 2 +- extra/tools/deploy/backend/backend.factor | 4 ++-- extra/tools/vocabs/vocabs.factor | 4 ++-- extra/tools/walker/walker.factor | 6 +++--- extra/ui/commands/commands-docs.factor | 2 +- extra/ui/gadgets/grid-lines/grid-lines.factor | 2 +- extra/ui/gadgets/panes/panes.factor | 2 +- extra/unix/process/process.factor | 2 +- extra/xmode/rules/rules.factor | 2 +- 62 files changed, 97 insertions(+), 97 deletions(-) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index d874243d71..ae99f9e6bf 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -45,7 +45,7 @@ GENERIC: c-type ( name -- type ) foldable : 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? [ @@ -162,7 +162,7 @@ DEFER: >c-ushort-array >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 ; @@ -199,12 +199,12 @@ M: long-long-type box-return ( type -- ) 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 [ 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 ; @@ -257,7 +257,7 @@ M: long-long-type box-return ( type -- ) #! staging violations dup array? [ unclip >r [ dup word? [ word-def call ] when ] map - r> add* + r> prefix ] when ; : malloc-file-contents ( path -- alien len ) diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 3e0062c85a..1a9d5b5392 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -18,7 +18,7 @@ IN: alien.compiler : alien-node-parameters* ( node -- seq ) dup parameters>> - swap return>> large-struct? [ "void*" add* ] when ; + swap return>> large-struct? [ "void*" prefix ] when ; : alien-node-return* ( node -- ctype ) return>> dup large-struct? [ drop "void" ] when ; diff --git a/core/alien/structs/structs-docs.factor b/core/alien/structs/structs-docs.factor index 6c7775de2b..e7e576293f 100755 --- a/core/alien/structs/structs-docs.factor +++ b/core/alien/structs/structs-docs.factor @@ -8,7 +8,7 @@ kernel words slots assocs namespaces ; dup ?word-name swap 2array over slot-spec-name rot slot-spec-type 2array 2array - [ { $instance } swap add ] assoc-map ; + [ { $instance } swap suffix ] assoc-map ; : $spec-reader-values ( slot-spec class -- ) ($spec-reader-values) $values ; @@ -16,9 +16,9 @@ kernel words slots assocs namespaces ; : $spec-reader-description ( slot-spec class -- ) [ "Outputs the value stored in the " , - { $snippet } rot slot-spec-name add , + { $snippet } rot slot-spec-name suffix , " slot of " , - { $instance } swap add , + { $instance } swap suffix , " instance." , ] { } make $description ; @@ -43,9 +43,9 @@ M: word slot-specs "slots" word-prop ; : $spec-writer-description ( slot-spec class -- ) [ "Stores a new value to the " , - { $snippet } rot slot-spec-name add , + { $snippet } rot slot-spec-name suffix , " slot of " , - { $instance } swap add , + { $instance } swap suffix , " instance." , ] { } make $description ; diff --git a/core/alien/structs/structs.factor b/core/alien/structs/structs.factor index e5de8ab83e..491f4351a3 100755 --- a/core/alien/structs/structs.factor +++ b/core/alien/structs/structs.factor @@ -16,7 +16,7 @@ IN: alien.structs ] 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 diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 2945bd2546..5d7c114cbc 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -138,10 +138,10 @@ C: anonymous-complement members>> [ class-and ] with map ; : left-anonymous-intersection-and ( first second -- class ) - >r members>> r> add ; + >r members>> r> suffix ; : right-anonymous-intersection-and ( first second -- class ) - members>> swap add ; + members>> swap suffix ; : (class-and) ( first second -- class ) { @@ -158,10 +158,10 @@ C: anonymous-complement } cond ; : left-anonymous-union-or ( first second -- class ) - >r members>> r> add ; + >r members>> r> suffix ; : right-anonymous-union-or ( first second -- class ) - members>> swap add ; + members>> swap suffix ; : (class-or) ( first second -- class ) { diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 435c7413a3..d6d1a72121 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -72,7 +72,7 @@ M: word reset-class drop ; ! update-map : class-uses ( class -- seq ) - dup members swap superclass [ add ] when* ; + dup members swap superclass [ suffix ] when* ; : class-usages ( class -- assoc ) [ update-map get at ] closure ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index eb6b3bd6e2..b771aa8920 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -35,7 +35,7 @@ TUPLE: check-mixin-class mixin ; 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? ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index a452d0eeec..fcce6a7b45 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -34,7 +34,7 @@ PRIVATE> : tuple>array ( tuple -- array ) dup tuple-layout [ layout-size swap [ array-nth ] curry map ] keep - layout-class add* ; + layout-class prefix ; : >tuple ( seq -- tuple ) dup first tuple-layout [ diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index e19847dbd4..484c7ab730 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -43,7 +43,7 @@ ERROR: 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 @@ -66,7 +66,7 @@ M: hashtable hashcode* reverse [ no-cond ] swap alist>quot ; : linear-case-quot ( default assoc -- quot ) - [ >r [ dupd = ] curry r> \ drop add* ] assoc-map + [ >r [ dupd = ] curry r> \ drop prefix ] assoc-map alist>quot ; : (distribute-buckets) ( buckets pair keys -- ) diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index 796388ffe1..a3ab256ea1 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -230,7 +230,7 @@ UNION: operand register indirect ; : 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 diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index f5409a24f5..261ada025b 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -156,7 +156,7 @@ IN: cpu.x86.intrinsics ! 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{ @@ -251,7 +251,7 @@ IN: cpu.x86.intrinsics \ 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 ; diff --git a/core/cpu/x86/sse2/sse2.factor b/core/cpu/x86/sse2/sse2.factor index 98e42fa7fe..9c477b4132 100755 --- a/core/cpu/x86/sse2/sse2.factor +++ b/core/cpu/x86/sse2/sse2.factor @@ -8,7 +8,7 @@ math.floats.private layouts quotations ; 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 ; @@ -23,7 +23,7 @@ IN: cpu.x86.sse2 ] 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 ; { diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 131b7e57c9..7dba7eb709 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -157,7 +157,7 @@ M: assoc update-methods ( assoc -- ) M: generic subwords dup "methods" word-prop values - swap "default-method" word-prop add ; + swap "default-method" word-prop suffix ; M: generic forget-word dup subwords [ forget ] each (forget-word) ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 4447c5a264..13b5278735 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -34,8 +34,8 @@ ERROR: no-method object generic ; : 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 ) @@ -137,7 +137,7 @@ ERROR: no-method object generic ; ] if ; : standard-methods ( word -- alist ) - dup methods swap default-method add* + dup methods swap default-method prefix [ 1quotation ] assoc-map ; M: standard-combination make-default-method diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 2a2e6995eb..5ca9b1b2e7 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -92,7 +92,7 @@ M: wrapper apply-object 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 ; @@ -109,7 +109,7 @@ TUPLE: recursive-quotation-error 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 @@ -430,7 +430,7 @@ M: #call-label collect-recursion* [ [ swap collect-recursion* ] curry each-node ] { } make ; : join-values ( node -- ) - collect-recursion [ node-in-d ] map meta-d get add + collect-recursion [ node-in-d ] map meta-d get suffix unify-lengths unify-stacks meta-d [ length tail* ] change ; diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index ed36ca4890..4aac98ce41 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -289,7 +289,7 @@ M: #label infer-classes-around ( #label -- ) dup annotate-node dup infer-classes-before dup infer-children - dup collect-recursion over add + dup collect-recursion over suffix pick annotate-entry node-child (infer-classes) ; diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 0b6cf04028..7fa2fbbcd3 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -205,7 +205,7 @@ UNION: #branch #if #dispatch ; 2dup 2slip rot [ 2drop t ] [ - >r dup node-children swap node-successor add r> + >r dup node-children swap node-successor suffix r> [ node-exists? ] curry contains? ] if ] [ diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 200208c6a5..4cfe0432a5 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -56,7 +56,7 @@ M: pair (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 diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 2ef26096e0..398fb6a068 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -59,7 +59,7 @@ M: tuple f decoder construct-boa ; over decoder-cr [ over cr- "\n" ?head [ - over stream-read1 [ add ] when* + over stream-read1 [ suffix ] when* ] when ] when nip ; diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index aef48452de..108c715ef0 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -60,7 +60,7 @@ sequences.private combinators ; [ value-literal sequence? ] [ drop f ] if ; : member-quot ( seq -- newquot ) - [ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ; + [ [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ; : expand-member ( #call -- ) dup node-in-d peek value-literal member-quot f splice-quot ; diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index 560a174289..cbdb1b9ec4 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -32,7 +32,7 @@ IN: optimizer.specializers : method-declaration ( method -- quot ) dup "method-generic" word-prop dispatch# object - swap "method-class" word-prop add* ; + swap "method-class" word-prop prefix ; : specialize-method ( quot method -- quot' ) method-declaration [ declare ] curry prepend ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 36e5decd05..58c68a3614 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -294,7 +294,7 @@ M: no-word-error summary scan { { ";" [ tuple f ] } { "<" [ scan-word ";" parse-tokens ] } - [ >r tuple ";" parse-tokens r> add* ] + [ >r tuple ";" parse-tokens r> prefix ] } case ; ERROR: staging-violation word ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index dfd5c1b32a..945678a0d8 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -14,7 +14,7 @@ C: slot-spec >r create-method r> define ; : define-slot-word ( class slot word quot -- ) - rot >fixnum add* define-typecheck ; + rot >fixnum prefix define-typecheck ; : reader-quot ( decl -- quot ) [ diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 9be1d5fc64..260a08c044 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -76,5 +76,5 @@ INSTANCE: groups sequence 1 head-slice* [ "\r" ?tail drop "\r" split ] map - ] keep peek "\r" split add concat + ] keep peek "\r" split suffix concat ] if ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 57947eefb0..1489750154 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -20,7 +20,7 @@ V{ : 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-dir? ( root name -- ? ) diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 886417b715..a6a5a014a7 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -82,7 +82,7 @@ SYMBOL: load-vocab-hook ! ( name -- ) : 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 ; diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index 30c3beb1ef..215b677e16 100755 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -49,7 +49,7 @@ HINTS: random fixnum ; : 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 diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index 8a1d93aceb..63fd55a550 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -32,7 +32,7 @@ VAR: color ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: 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 ; diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index 647c83d667..0480235dfe 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -21,7 +21,7 @@ M: color-preview model-changed swap model-value over set-gadget-interior relayout-1 ; : ( model -- model ) - [ [ 256 /f ] map 1 add ] ; + [ [ 256 /f ] map 1 suffix ] ; : ( -- model gadget ) 3 [ drop 0 0 0 255 ] map diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 7f24d6258f..eadd1a03e8 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -27,7 +27,7 @@ M: tuple-class group-words swap [ slot-spec-writer ] map append ; : define-consult-method ( word class quot -- ) - pick add >r swap create-method r> define ; + pick suffix >r swap create-method r> define ; : define-consult ( class group quot -- ) >r group-words swap r> diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index 85d58e7572..c442dfaa94 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -43,7 +43,7 @@ SYMBOL: edit-hook : fix ( word -- ) "Fixing " write dup pprint " and all usages..." print nl - dup usage swap add* [ + dup usage swap prefix [ "Editing " write dup . "RETURN moves on to the next usage, C+d stops." print flush diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor index c6d9cd04d2..1022a02d7e 100644 --- a/extra/faq/faq.factor +++ b/extra/faq/faq.factor @@ -69,7 +69,7 @@ C: faq : html>faq ( div -- faq ) unclip swap { "h3" "ol" } [ tags-named ] with map - first2 >r f add* r> [ html>question-list ] 2map ; + first2 >r f prefix r> [ html>question-list ] 2map ; : header, ( faq -- ) dup faq-header , diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor index 490ce992ab..d983bd2715 100755 --- a/extra/fry/fry.factor +++ b/extra/fry/fry.factor @@ -28,7 +28,7 @@ DEFER: (fry) ! to avoid confusion, remove if fry goes core { namespaces:, [ [ curry ] ((fry)) ] } - [ swap >r add r> (fry) ] + [ swap >r suffix r> (fry) ] } case ] if ; diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 5dc7255eed..e933894674 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -235,7 +235,7 @@ M: string ($instance) : 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 diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index f286690d37..add37173b7 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -184,7 +184,7 @@ DEFER: (d) [ 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 ) @@ -203,7 +203,7 @@ DEFER: (d) [ basis graded ] bi@ tensor bigraded-ker/im-d [ [ [ first ] map ] map ] keep [ [ second ] map 2 head* { 0 0 } prepend ] map - 1 tail dup first length 0 add + 1 tail dup first length 0 suffix [ v- ] 2map ; ! Laplacian diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index 52cca64b2f..f642d8881c 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -365,7 +365,7 @@ M: lazy-concat nil? ( lazy-concat -- bool ) 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 ; diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 5da0225be9..fe4bd65c14 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -108,7 +108,7 @@ UNION: special local quote local-word local-reader local-writer ; : point-free-end ( quot args -- newquot ) over peek special? [ drop-locals >r >r peek r> localize r> append ] - [ drop-locals nip swap peek add ] + [ drop-locals nip swap peek suffix ] if ; : (point-free) ( quot args -- newquot ) @@ -130,9 +130,9 @@ GENERIC: free-vars ( form -- vars ) : add-if-free ( vars object -- vars ) { - { [ dup local-writer? ] [ "local-reader" word-prop add ] } - { [ dup lexical? ] [ add ] } - { [ dup quote? ] [ quote-local add ] } + { [ dup local-writer? ] [ "local-reader" word-prop suffix ] } + { [ dup lexical? ] [ suffix ] } + { [ dup quote? ] [ quote-local suffix ] } { [ t ] [ free-vars append ] } } cond ; diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index 42545500a5..664337c3d3 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -17,7 +17,7 @@ SYMBOL: CRITICAL { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ; : send-to-log-server ( array string -- ) - add* "log-server" get send ; + prefix "log-server" get send ; SYMBOL: log-service diff --git a/extra/lsys/tortoise/graphics/graphics.factor b/extra/lsys/tortoise/graphics/graphics.factor index d8429e7aaf..87536476ee 100644 --- a/extra/lsys/tortoise/graphics/graphics.factor +++ b/extra/lsys/tortoise/graphics/graphics.factor @@ -77,7 +77,7 @@ VAR: color-table { 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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor index 99a098ca09..487d9828ea 100644 --- a/extra/math/combinatorics/combinatorics.factor +++ b/extra/math/combinatorics/combinatorics.factor @@ -18,7 +18,7 @@ IN: math.combinatorics 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 ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index ac62fb08f9..5ea19bc957 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -191,14 +191,14 @@ M: hook-combination generic-prologue [ delete-at ] with-methods ; : method>spec ( method -- spec ) - dup method-classes swap method-generic add* ; + dup method-classes swap method-generic prefix ; : parse-method ( -- quot classes generic ) parse-definition dup 2 tail over second rot first ; : METHOD: location - >r parse-method [ define-method ] 2keep add* r> + >r parse-method [ define-method ] 2keep prefix r> remember-definition ; parsing ! For compatibility diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor index 01725ee9a9..fd9be4eb12 100644 --- a/extra/opengl/gl/extensions/extensions.factor +++ b/extra/opengl/gl/extensions/extensions.factor @@ -38,7 +38,7 @@ reset-gl-function-number-counter 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 diff --git a/extra/oracle/oracle.factor b/extra/oracle/oracle.factor index d725de5994..a30ce64854 100644 --- a/extra/oracle/oracle.factor +++ b/extra/oracle/oracle.factor @@ -236,13 +236,13 @@ C: connection : fetch-each ( object -- object ) fetch-statement [ - buf get alien>char-string res get swap add res set + buf get alien>char-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 alien>char-string res get swap suffix res set fetch-each ] [ ] if ; diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index d6aacf9645..d8fccfb8f9 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -132,7 +132,7 @@ TUPLE: and-parser parsers ; : <&> ( parser1 parser2 -- parser ) over and-parser? [ - >r and-parser-parsers r> add + >r and-parser-parsers r> suffix ] [ 2array ] if and-parser construct-boa ; @@ -239,11 +239,11 @@ M: some-parser parse ( input parser -- result ) : <:&> ( 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. diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 68aab7d820..514a29781e 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -104,7 +104,7 @@ C: peg-head :: (setup-lr) ( r l s -- ) s head>> l head>> eq? [ l head>> s (>>head) - l head>> [ s rule>> add ] change-involved-set drop + l head>> [ s rule>> suffix ] change-involved-set drop r l s next>> (setup-lr) ] unless ; @@ -136,7 +136,7 @@ C: peg-head h [ p heads get at ] | h [ - m r h involved-set>> h rule>> add member? not and [ + m r h involved-set>> h rule>> suffix member? not and [ fail p ] [ r h eval-set>> member? [ diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor index ffe3a4bca1..cf09277f31 100644 --- a/extra/project-euler/043/043.factor +++ b/extra/project-euler/043/043.factor @@ -76,10 +76,10 @@ PRIVATE> 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 seq-diff first prefix ; : interesting-pandigitals ( -- seq ) 17 candidates { 13 11 7 5 3 2 } [ diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 087b216b3a..5829f66c01 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -72,7 +72,7 @@ PRIVATE> : 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 ; @@ -95,7 +95,7 @@ PRIVATE> ! 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 ; diff --git a/extra/qualified/qualified.factor b/extra/qualified/qualified.factor index b4eb4558fa..69e4c09b6e 100644 --- a/extra/qualified/qualified.factor +++ b/extra/qualified/qualified.factor @@ -4,7 +4,7 @@ IN: qualified : define-qualified ( vocab-name -- ) dup require - dup vocab-words swap CHAR: : add + dup vocab-words swap CHAR: : suffix [ -rot >r append r> ] curry assoc-map use get push ; diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index fa36a7c6f8..b0cd61bd8f 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -21,7 +21,7 @@ SYMBOL: ignore-case? 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 <@ ; diff --git a/extra/regexp2/regexp2.factor b/extra/regexp2/regexp2.factor index 1f2bbde171..8c26d880f1 100644 --- a/extra/regexp2/regexp2.factor +++ b/extra/regexp2/regexp2.factor @@ -21,7 +21,7 @@ SYMBOL: ignore-case? 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 ; diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 0b93552e76..d246b16b8d 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -94,7 +94,7 @@ MACRO: firstn ( n -- ) : monotonic-split ( seq quot -- newseq ) [ - >r dup unclip add r> + >r dup unclip suffix r> v, [ pick ,, call [ v, ] unless ] curry 2each ,v ] { } make ; diff --git a/extra/springies/springies.factor b/extra/springies/springies.factor index 3a1af786e2..cd6e1a7cfb 100644 --- a/extra/springies/springies.factor +++ b/extra/springies/springies.factor @@ -235,7 +235,7 @@ C: spring 6 nrot 6 nrot 2array 5 nrot 5 nrot 2array 0 0 2array - nodes> swap add >nodes ; + nodes> swap suffix >nodes ; : spng ( id id-a id-b k damp rest-length -- ) 6 nrot drop @@ -243,4 +243,4 @@ C: spring 5 nrot node-id 5 nrot node-id - springs> swap add >springs ; + springs> swap suffix >springs ; diff --git a/extra/state-machine/state-machine.factor b/extra/state-machine/state-machine.factor index cd3cfc6324..489b7aaeb4 100755 --- a/extra/state-machine/state-machine.factor +++ b/extra/state-machine/state-machine.factor @@ -6,7 +6,7 @@ IN: state-machine ! STATES: set-name state1 state2 ... ; ";" parse-tokens [ length ] keep - unclip add + unclip suffix [ create-in swap 1quotation define ] 2each ; parsing TUPLE: state place data ; diff --git a/extra/tetris/board/board.factor b/extra/tetris/board/board.factor index 13850f6bd7..93bbebf34f 100644 --- a/extra/tetris/board/board.factor +++ b/extra/tetris/board/board.factor @@ -37,7 +37,7 @@ TUPLE: board width height rows ; : add-row ( board -- ) dup board-rows over board-width f - add* swap set-board-rows ; + prefix swap set-board-rows ; : top-up-rows ( board -- ) dup board-height over board-rows length = [ diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index b019326ed5..395c4ff924 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -46,7 +46,7 @@ IN: tools.deploy.backend : staging-image-name ( profile -- name ) "staging." - swap strip-word-names? [ "strip" add ] when + swap strip-word-names? [ "strip" suffix ] when "-" join ".image" 3append temp-file ; DEFER: ?make-staging-image @@ -75,7 +75,7 @@ DEFER: ?make-staging-image ] { } make ; : run-factor ( vm flags -- ) - swap add* dup . run-with-output ; inline + swap prefix dup . run-with-output ; inline : make-staging-image ( profile -- ) vm swap staging-command-line run-factor ; diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index d7610c21c8..2f941ad2ce 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -230,7 +230,7 @@ MEMO: all-vocabs-seq ( -- seq ) try-everything load-failures. ; : unrooted-child-vocabs ( prefix -- seq ) - dup empty? [ CHAR: . add ] unless + dup empty? [ CHAR: . suffix ] unless vocabs [ find-vocab-root not ] subset [ @@ -242,7 +242,7 @@ MEMO: all-vocabs-seq ( -- seq ) vocab-roots get [ dup pick (all-child-vocabs) [ >vocab-link ] map ] { } map>assoc - swap unrooted-child-vocabs f swap 2array add ; + swap unrooted-child-vocabs f swap 2array suffix ; : all-child-vocabs-seq ( prefix -- assoc ) vocab-roots get swap [ diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index 2aed793a59..d548c0a4f5 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -49,10 +49,10 @@ DEFER: start-walker-thread \ break t "break?" set-word-prop : walk ( quot -- quot' ) - \ break add* [ break rethrow ] recover ; + \ break prefix [ break rethrow ] recover ; : add-breakpoint ( quot -- quot' ) - dup [ break ] head? [ \ break add* ] unless ; + dup [ break ] head? [ \ break prefix ] unless ; : (step-into-quot) ( quot -- ) add-breakpoint call ; @@ -114,7 +114,7 @@ SYMBOL: +stopped+ ] change-frame ; : step-out-msg ( continuation -- continuation' ) - [ nip \ break add ] change-frame ; + [ nip \ break suffix ] change-frame ; { { call [ (step-into-quot) ] } diff --git a/extra/ui/commands/commands-docs.factor b/extra/ui/commands/commands-docs.factor index 789d9b9e6a..ed524148e3 100644 --- a/extra/ui/commands/commands-docs.factor +++ b/extra/ui/commands/commands-docs.factor @@ -14,7 +14,7 @@ IN: ui.commands : 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 -- ) diff --git a/extra/ui/gadgets/grid-lines/grid-lines.factor b/extra/ui/gadgets/grid-lines/grid-lines.factor index fce88c0ebb..533116824b 100755 --- a/extra/ui/gadgets/grid-lines/grid-lines.factor +++ b/extra/ui/gadgets/grid-lines/grid-lines.factor @@ -18,7 +18,7 @@ SYMBOL: grid-dim 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 ; diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 52c5ca8a02..91b7f0f225 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -352,7 +352,7 @@ M: f sloppy-pick-up* : 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 ; diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor index fc8103b656..ba02f15c7a 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -9,7 +9,7 @@ IN: unix.process ! io.launcher instead. : >argv ( seq -- alien ) - [ malloc-char-string ] map f add >c-void*-array ; + [ malloc-char-string ] map f suffix >c-void*-array ; : exec ( pathname argv -- int ) [ malloc-char-string ] [ >argv ] bi* execv ; diff --git a/extra/xmode/rules/rules.factor b/extra/xmode/rules/rules.factor index 28237a7b2c..8c74d61656 100755 --- a/extra/xmode/rules/rules.factor +++ b/extra/xmode/rules/rules.factor @@ -113,7 +113,7 @@ M: regexp text-hash-char drop f ; : 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 From 9e96befa6981f39a27d120de93bab283d7468668 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 31 Mar 2008 19:24:29 -0600 Subject: [PATCH 357/886] Remove add and add* --- core/sequences/sequences.factor | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 26c1013c28..ca46066861 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -478,31 +478,18 @@ M: sequence <=> : push-new ( elt seq -- ) [ delete ] 2keep push ; -: add* ( seq elt -- newseq ) - over >r over length 1+ r> [ - [ 0 swap set-nth-unsafe ] keep - [ 1 swap copy ] keep - ] new-like ; - : prefix ( seq elt -- newseq ) over >r over length 1+ r> [ [ 0 swap set-nth-unsafe ] keep [ 1 swap copy ] keep ] new-like ; -: add ( seq elt -- newseq ) - over >r over length 1+ r> [ - [ >r over length r> set-nth-unsafe ] keep - [ 0 swap copy ] keep - ] new-like ; - : suffix ( seq elt -- newseq ) over >r over length 1+ r> [ [ >r over length r> set-nth-unsafe ] keep [ 0 swap copy ] keep ] new-like ; - : seq-diff ( seq1 seq2 -- newseq ) swap [ member? not ] curry subset ; From e75222d039076608fee57a25b5a7fefefdd1a5c5 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 31 Mar 2008 19:24:48 -0600 Subject: [PATCH 358/886] More add and add* cleanups --- core/math/intervals/intervals-tests.factor | 2 +- core/prettyprint/prettyprint-tests.factor | 2 +- core/quotations/quotations-tests.factor | 4 ++-- core/sequences/sequences-docs.factor | 16 ++++++++-------- extra/sequences/deep/deep-tests.factor | 2 +- 5 files changed, 13 insertions(+), 13 deletions(-) diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index f6317e7475..5204d7d45a 100755 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -188,7 +188,7 @@ IN: math.intervals.tests { max interval-max } } "math.ratios.private" vocab [ - { / interval/ } add + { / interval/ } suffix ] when random ; diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 35b30ac46f..27b63ec26f 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -192,7 +192,7 @@ unit-test "IN: prettyprint.tests" ": another-soft-break-layout ( node -- quot )" " parse-error-file" - " [ \"hello world foo\" add ] [ ] make ;" + " [ \"hello world foo\" suffix ] [ ] make ;" } ; [ t ] [ diff --git a/core/quotations/quotations-tests.factor b/core/quotations/quotations-tests.factor index a4c9a619b5..d311dfad71 100755 --- a/core/quotations/quotations-tests.factor +++ b/core/quotations/quotations-tests.factor @@ -10,8 +10,8 @@ IN: quotations.tests ] 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 diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 9e8dcd6559..f5e5bfcdb3 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -61,8 +61,8 @@ ARTICLE: "sequences-access" "Accessing sequence elements" 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 } ; @@ -641,22 +641,22 @@ HELP: push-new } { $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 @@ -940,7 +940,7 @@ HELP: unclip { $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 diff --git a/extra/sequences/deep/deep-tests.factor b/extra/sequences/deep/deep-tests.factor index 541570f3f9..9629d569cb 100755 --- a/extra/sequences/deep/deep-tests.factor +++ b/extra/sequences/deep/deep-tests.factor @@ -11,7 +11,7 @@ IN: sequences.deep.tests [ { { "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 From 122fd50d4a7fee989bdcf69dc699d7bcf4246600 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Tue, 1 Apr 2008 14:49:20 +1300 Subject: [PATCH 359/886] Throw error when ebnf uses a non-existant non-terminal --- extra/peg/ebnf/ebnf.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 26e5d68df8..a6567ce8f3 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -310,9 +310,14 @@ M: ebnf-var (transform) ( ast -- parser ) M: ebnf-terminal (transform) ( ast -- parser ) symbol>> token sp ; +: parser-not-found ( name -- * ) + [ + "Parser " % % " not found." % + ] "" make throw ; + M: ebnf-non-terminal (transform) ( ast -- parser ) symbol>> [ - , parser get , \ at , \ sp , + , \ dup , parser get , \ at , [ parser-not-found ] , \ unless* , \ sp , \ nip , ] [ ] make box ; : transform-ebnf ( string -- object ) From cc5ddd8d78fcdb9b18b438002fe415738a12880b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 31 Mar 2008 20:05:06 -0600 Subject: [PATCH 360/886] Resolve more add/add* items --- core/bootstrap/image/image.factor | 2 +- core/classes/tuple/tuple.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 5d49203554..fc963683b6 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -305,7 +305,7 @@ M: float-array ' float-array emit-dummy-array ; ! Tuples : (emit-tuple) ( tuple -- pointer ) [ tuple>array 1 tail-slice ] - [ class transfer-word tuple-layout ] bi add* [ ' ] map + [ class transfer-word tuple-layout ] bi prefix [ ' ] map tuple type-number dup [ emit-seq ] emit-object ; : emit-tuple ( tuple -- pointer ) diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index de1e3bddb8..3cacef25a1 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -130,7 +130,7 @@ PRIVATE> ] with each ; : all-slot-names ( class -- slots ) - superclasses [ slot-names ] map concat \ class add* ; + superclasses [ slot-names ] map concat \ class prefix ; : compute-slot-permutation ( class old-slot-names -- permutation ) >r all-slot-names r> [ index ] curry map ; From c71a3e05c6a666ceba1353243b89c2d301c8cbd5 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 31 Mar 2008 20:29:12 -0600 Subject: [PATCH 361/886] Fix add references --- core/cpu/ppc/intrinsics/intrinsics.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 7aa78ce52e..07698eaa92 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -94,14 +94,14 @@ IN: cpu.ppc.intrinsics } 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" } } @@ -205,11 +205,11 @@ IN: cpu.ppc.intrinsics } 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 -- ) @@ -336,7 +336,7 @@ IN: cpu.ppc.intrinsics } 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" } } @@ -352,7 +352,7 @@ IN: cpu.ppc.intrinsics ] 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 ; { From 6a2ab7393811e75e1b697a9180a3287f66bdf859 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 31 Mar 2008 20:32:31 -0600 Subject: [PATCH 362/886] Fix more add/add* occurances --- extra/cocoa/subclassing/subclassing.factor | 2 +- extra/windows/com/syntax/syntax.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/cocoa/subclassing/subclassing.factor b/extra/cocoa/subclassing/subclassing.factor index 42ddce1206..48f45f21c0 100755 --- a/extra/cocoa/subclassing/subclassing.factor +++ b/extra/cocoa/subclassing/subclassing.factor @@ -76,7 +76,7 @@ IN: cocoa.subclassing r> class_addMethods ; : encode-types ( return types -- encoding ) - swap add* [ + swap prefix [ alien>objc-types get at "0" append ] map concat ; diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor index 238ff18c39..acd3848f10 100755 --- a/extra/windows/com/syntax/syntax.factor +++ b/extra/windows/com/syntax/syntax.factor @@ -40,7 +40,7 @@ unless : (parse-com-function) ( tokens -- definition ) [ second ] [ first ] - [ 3 tail 2 group [ first ] map "void*" add* ] + [ 3 tail 2 group [ first ] map "void*" prefix ] tri ; From 38cb4f13b682f577bd30ef27c7e6daf6fee43c6b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 1 Apr 2008 01:40:12 -0500 Subject: [PATCH 363/886] Add 3cleave --- core/combinators/combinators.factor | 8 +++++++- core/inference/transforms/transforms.factor | 2 ++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index e19847dbd4..276e4cb184 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -12,11 +12,17 @@ hashtables sorting ; [ [ keep ] curry ] map concat [ drop ] append ; : 2cleave ( x seq -- ) - [ [ call ] 3keep drop ] each 2drop ; + [ 2keep ] each 2drop ; : 2cleave>quot ( seq -- quot ) [ [ 2keep ] curry ] map concat [ 2drop ] append ; +: 3cleave ( x seq -- ) + [ 3keep ] each 3drop ; + +: 3cleave>quot ( seq -- quot ) + [ [ 3keep ] curry ] map concat [ 3drop ] append ; + : spread>quot ( seq -- quot ) [ length [ >r ] concat ] [ [ [ r> ] prepend ] map concat ] bi diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 200208c6a5..4d636c24f2 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -43,6 +43,8 @@ IN: inference.transforms \ 2cleave [ 2cleave>quot ] 1 define-transform +\ 3cleave [ 3cleave>quot ] 1 define-transform + \ spread [ spread>quot ] 1 define-transform ! Bitfields From 2223633b432cd5f103fceefcf026d2b382e71f64 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 1 Apr 2008 01:40:30 -0500 Subject: [PATCH 364/886] Tweak --- core/generic/standard/standard.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 4447c5a264..3898150c3b 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -39,9 +39,7 @@ ERROR: no-method object generic ; ] [ ] make ; : class-predicates ( assoc -- assoc ) - [ - >r >r picker r> "predicate" word-prop append r> - ] assoc-map ; + [ >r "predicate" word-prop picker prepend r> ] assoc-map ; : (simplify-alist) ( class i assoc -- default assoc ) 2dup length 1- = [ From 7cb9be06e5c303d0c390a44e8e034b180bc93fcd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 1 Apr 2008 16:46:22 -0500 Subject: [PATCH 365/886] redo singletons --- extra/singleton/singleton-docs.factor | 12 ------------ extra/singleton/singleton-tests.factor | 5 ++++- extra/singleton/singleton.factor | 15 +++++++++++---- 3 files changed, 15 insertions(+), 17 deletions(-) diff --git a/extra/singleton/singleton-docs.factor b/extra/singleton/singleton-docs.factor index 92ddcc494a..7acf97a436 100644 --- a/extra/singleton/singleton-docs.factor +++ b/extra/singleton/singleton-docs.factor @@ -12,15 +12,3 @@ HELP: SINGLETON: } { $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: -} ; diff --git a/extra/singleton/singleton-tests.factor b/extra/singleton/singleton-tests.factor index 1698181ed3..da2a74f8d1 100644 --- a/extra/singleton/singleton-tests.factor +++ b/extra/singleton/singleton-tests.factor @@ -1,4 +1,4 @@ -USING: kernel singleton tools.test ; +USING: kernel singleton tools.test prettyprint io.streams.string ; IN: singleton.tests [ ] [ SINGLETON: bzzt ] unit-test @@ -7,3 +7,6 @@ IN: singleton.tests GENERIC: zammo ( obj -- ) [ ] [ M: bzzt zammo drop "yes!" ; ] unit-test [ "yes!" ] [ bzzt zammo ] unit-test +[ ] [ SINGLETON: omg ] unit-test +[ t ] [ omg singleton? ] unit-test +[ "USING: singleton ;\nIN: singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor index 9ec9f2f4a3..99319fdfdb 100755 --- a/extra/singleton/singleton.factor +++ b/extra/singleton/singleton.factor @@ -1,16 +1,23 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: classes.predicate kernel namespaces parser quotations -sequences words ; +sequences words prettyprint prettyprint.backend prettyprint.sections +compiler.units classes ; +USE: tools.walker IN: singleton +PREDICATE: singleton < predicate-class + [ "predicate-definition" word-prop ] + [ [ eq? ] curry ] bi sequence= ; + : define-singleton ( token -- ) create-class-in - \ word + dup save-location + \ singleton over [ eq? ] curry define-predicate-class ; : SINGLETON: scan define-singleton ; parsing -: SINGLETONS: - ";" parse-tokens [ define-singleton ] each ; parsing +M: singleton see-class* ( class -- ) + Date: Tue, 1 Apr 2008 16:51:48 -0500 Subject: [PATCH 366/886] rename singletons --- extra/{ => classes}/singleton/authors.txt | 0 extra/{ => classes}/singleton/singleton-docs.factor | 2 +- extra/{ => classes}/singleton/singleton-tests.factor | 4 ++-- extra/{ => classes}/singleton/singleton.factor | 3 +-- 4 files changed, 4 insertions(+), 5 deletions(-) rename extra/{ => classes}/singleton/authors.txt (100%) rename extra/{ => classes}/singleton/singleton-docs.factor (96%) rename extra/{ => classes}/singleton/singleton-tests.factor (70%) rename extra/{ => classes}/singleton/singleton.factor (95%) diff --git a/extra/singleton/authors.txt b/extra/classes/singleton/authors.txt similarity index 100% rename from extra/singleton/authors.txt rename to extra/classes/singleton/authors.txt diff --git a/extra/singleton/singleton-docs.factor b/extra/classes/singleton/singleton-docs.factor similarity index 96% rename from extra/singleton/singleton-docs.factor rename to extra/classes/singleton/singleton-docs.factor index 7acf97a436..95b5b6af18 100644 --- a/extra/singleton/singleton-docs.factor +++ b/extra/classes/singleton/singleton-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax kernel words ; -IN: singleton +IN: classes.singleton HELP: SINGLETON: { $syntax "SINGLETON: class" diff --git a/extra/singleton/singleton-tests.factor b/extra/classes/singleton/singleton-tests.factor similarity index 70% rename from extra/singleton/singleton-tests.factor rename to extra/classes/singleton/singleton-tests.factor index da2a74f8d1..453a2a0ea5 100644 --- a/extra/singleton/singleton-tests.factor +++ b/extra/classes/singleton/singleton-tests.factor @@ -1,5 +1,5 @@ USING: kernel singleton tools.test prettyprint io.streams.string ; -IN: singleton.tests +IN: classes.singleton.tests [ ] [ SINGLETON: bzzt ] unit-test [ t ] [ bzzt bzzt? ] unit-test @@ -9,4 +9,4 @@ GENERIC: zammo ( obj -- ) [ "yes!" ] [ bzzt zammo ] unit-test [ ] [ SINGLETON: omg ] unit-test [ t ] [ omg singleton? ] unit-test -[ "USING: singleton ;\nIN: singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test +[ "USING: singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test diff --git a/extra/singleton/singleton.factor b/extra/classes/singleton/singleton.factor similarity index 95% rename from extra/singleton/singleton.factor rename to extra/classes/singleton/singleton.factor index 99319fdfdb..61a519679c 100755 --- a/extra/singleton/singleton.factor +++ b/extra/classes/singleton/singleton.factor @@ -3,8 +3,7 @@ USING: classes.predicate kernel namespaces parser quotations sequences words prettyprint prettyprint.backend prettyprint.sections compiler.units classes ; -USE: tools.walker -IN: singleton +IN: classes.singleton PREDICATE: singleton < predicate-class [ "predicate-definition" word-prop ] From b4adebb6910278f1ca140552510f5278abd7f25e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 1 Apr 2008 16:53:32 -0500 Subject: [PATCH 367/886] update usages of singleton --- extra/db/types/types.factor | 2 +- extra/http/server/auth/providers/db/db.factor | 84 ++++++++--------- .../http/server/sessions/storage/db/db.factor | 92 +++++++++---------- 3 files changed, 89 insertions(+), 89 deletions(-) diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 9babfbcdb0..98bc451a6f 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -4,7 +4,7 @@ USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib words namespaces tools.walker slots slots.private classes mirrors classes.tuple combinators calendar.format symbols -singleton ; +classes.singleton ; IN: db.types HOOK: modifier-table db ( -- hash ) diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor index 1e84e544b8..deab40e8d4 100755 --- a/extra/http/server/auth/providers/db/db.factor +++ b/extra/http/server/auth/providers/db/db.factor @@ -1,42 +1,42 @@ -! 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 -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 ) - - 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. +! 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 ) + + 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 ; diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor index 471b7fa6df..e573b22ba1 100755 --- a/extra/http/server/sessions/storage/db/db.factor +++ b/extra/http/server/sessions/storage/db/db.factor @@ -1,46 +1,46 @@ -! 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 singleton -math.parser ; -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 ; - -: ( id -- session ) - session construct-empty - swap dup [ string>number ] when >>id ; - -M: sessions-in-db get-session ( id storage -- namespace/f ) - drop - dup [ - - select-tuple dup [ namespace>> ] when - ] when ; - -M: sessions-in-db update-session ( namespace id storage -- ) - drop - - swap >>namespace - update-tuple ; - -M: sessions-in-db delete-session ( id storage -- ) - drop - - delete-tuple ; - -M: sessions-in-db new-session ( namespace storage -- id ) - drop - f - swap >>namespace - [ insert-tuple ] [ id>> number>string ] bi ; +! 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 ; + +: ( id -- session ) + session construct-empty + swap dup [ string>number ] when >>id ; + +M: sessions-in-db get-session ( id storage -- namespace/f ) + drop + dup [ + + select-tuple dup [ namespace>> ] when + ] when ; + +M: sessions-in-db update-session ( namespace id storage -- ) + drop + + swap >>namespace + update-tuple ; + +M: sessions-in-db delete-session ( id storage -- ) + drop + + delete-tuple ; + +M: sessions-in-db new-session ( namespace storage -- id ) + drop + f + swap >>namespace + [ insert-tuple ] [ id>> number>string ] bi ; From 23768dd482037e93cc4764d3bbbfc9eb31e496a7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 1 Apr 2008 17:06:36 -0500 Subject: [PATCH 368/886] remove singleton? from sequences.lib fix bootstrap error --- extra/math/polynomials/polynomials.factor | 2 +- extra/math/text/english/english.factor | 2 +- extra/random/unix/unix.factor | 2 +- extra/sequences/lib/lib-tests.factor | 3 --- extra/sequences/lib/lib.factor | 3 --- 5 files changed, 3 insertions(+), 9 deletions(-) diff --git a/extra/math/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor index d6ac71e629..0b0d3520ef 100644 --- a/extra/math/polynomials/polynomials.factor +++ b/extra/math/polynomials/polynomials.factor @@ -22,7 +22,7 @@ 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 ] bi@ ; : p+ ( p p -- p ) pextend v+ ; diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor index b77ac725ab..cba8c28310 100755 --- a/extra/math/text/english/english.factor +++ b/extra/math/text/english/english.factor @@ -79,7 +79,7 @@ SYMBOL: and-needed? ] if ; : recombine ( seq -- str ) - dup singleton? [ + dup length 1 = [ first 3digits>text ] [ dup set-conjunction "" swap diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor index f3f55007f0..3be2697bdf 100644 --- a/extra/random/unix/unix.factor +++ b/extra/random/unix/unix.factor @@ -1,5 +1,5 @@ USING: alien.c-types io io.files io.nonblocking kernel -namespaces random io.encodings.binary singleton init +namespaces random io.encodings.binary init accessors system ; IN: random.unix diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 6e6a924382..99565e966c 100755 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -46,9 +46,6 @@ IN: sequences.lib.tests [ { 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 diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index d246b16b8d..945ba1a3b7 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -98,9 +98,6 @@ MACRO: firstn ( n -- ) v, [ pick ,, call [ v, ] unless ] curry 2each ,v ] { } make ; -: singleton? ( seq -- ? ) - length 1 = ; - : delete-random ( seq -- value ) [ length random ] keep [ nth ] 2keep delete-nth ; From d1c9082cd426c3e96980fc94d2c37323fd73e4fb Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 1 Apr 2008 16:22:14 -0600 Subject: [PATCH 369/886] combinators.cleave: Major insurgency assault --- extra/combinators/cleave/cleave.factor | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index d99fe7e1d2..8018adaaa4 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -1,5 +1,5 @@ -USING: kernel sequences macros combinators ; +USING: kernel arrays sequences macros combinators ; IN: combinators.cleave @@ -21,6 +21,18 @@ MACRO: <2arr> ( seq -- ) [ >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 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -28,3 +40,8 @@ MACRO: <2arr> ( seq -- ) MACRO: ( 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 From a80e95ac2d65de8b96edfdbb638a06551cfbdf2b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 1 Apr 2008 18:02:39 -0500 Subject: [PATCH 370/886] fix using --- extra/classes/singleton/singleton-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/classes/singleton/singleton-tests.factor b/extra/classes/singleton/singleton-tests.factor index 453a2a0ea5..08f4a77aad 100644 --- a/extra/classes/singleton/singleton-tests.factor +++ b/extra/classes/singleton/singleton-tests.factor @@ -1,4 +1,4 @@ -USING: kernel singleton tools.test prettyprint io.streams.string ; +USING: kernel classes.singleton tools.test prettyprint io.streams.string ; IN: classes.singleton.tests [ ] [ SINGLETON: bzzt ] unit-test From 5b65e02851207ae91bde1245562c79ade2eb10ed Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 1 Apr 2008 17:48:49 -0600 Subject: [PATCH 371/886] Project for a new American stack effect --- extra/newfx/newfx.factor | 50 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) create mode 100644 extra/newfx/newfx.factor diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor new file mode 100644 index 0000000000..a5db87ca37 --- /dev/null +++ b/extra/newfx/newfx.factor @@ -0,0 +1,50 @@ + +USING: kernel sequences assocs qualified ; + +QUALIFIED: sequences + +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 + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: nth-at ( seq i -- val ) swap nth ; +: nth-of ( i seq -- val ) nth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: nth-is ( seq i val -- seq ) swap pick set-nth ; + +: is-nth ( seq val i -- seq ) pick set-nth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: at-key ( tbl key -- val ) swap at ; +: key-of ( key tbl -- val ) at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: key-is ( tbl key val -- tbl ) swap pick set-at ; +: is-key ( tbl val key -- tbl ) pick set-at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: push ( seq obj -- seq ) over sequences:push ; +: push-on ( obj seq -- seq ) tuck 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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + From 6b454eed36490c35cd928e8b5b932f4e3ba2dc6d Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 2 Apr 2008 12:59:12 +1300 Subject: [PATCH 372/886] Various peg/ebnf fixes - Box parsers were broken when involved in left recursion detection - ebnf no longer implicitly ignores white space between terminates/non-terminals - ebnf now handles \t and \n in grammars so productions to detect white space work - reset-delegates is now reset-pegs --- extra/peg/ebnf/ebnf-tests.factor | 53 ++++++++++++++++++++++++++++++-- extra/peg/ebnf/ebnf.factor | 13 +++++--- extra/peg/peg.factor | 24 +++++++++------ 3 files changed, 74 insertions(+), 16 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 4f802c5207..84c492c55a 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -180,6 +180,55 @@ IN: peg.ebnf.tests { 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 @@ -200,7 +249,7 @@ IN: peg.ebnf.tests EBNF: primary Primary = PrimaryNoNewArray -PrimaryNoNewArray = ClassInstanceCreationExpression +PrimaryNoNewArray = ClassInstanceCreationExpression | MethodInvocation | FieldAccess | ArrayAccess @@ -211,7 +260,7 @@ MethodInvocation = Primary "." MethodName "(" ")" | MethodName "(" ")" FieldAccess = Primary "." Identifier | "super" "." Identifier -ArrayAccess = Primary "[" Expression "]" +ArrayAccess = Primary "[" Expression "]" | ExpressionName "[" Expression "]" ClassOrInterfaceType = ClassName | InterfaceTypeName ClassName = "C" | "D" diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index a6567ce8f3..a4e4fe387d 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -3,7 +3,7 @@ USING: kernel compiler.units parser words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg peg.parsers unicode.categories multiline combinators.lib - splitting accessors effects sequences.deep ; + splitting accessors effects sequences.deep peg.search ; IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; @@ -308,7 +308,7 @@ M: ebnf-var (transform) ( ast -- parser ) dup vars get push [ dupd set ] curry action ; M: ebnf-terminal (transform) ( ast -- parser ) - symbol>> token sp ; + symbol>> token ; : parser-not-found ( name -- * ) [ @@ -317,7 +317,7 @@ M: ebnf-terminal (transform) ( ast -- parser ) M: ebnf-non-terminal (transform) ( ast -- parser ) symbol>> [ - , \ dup , parser get , \ at , [ parser-not-found ] , \ unless* , \ sp , \ nip , + , \ dup , parser get , \ at , [ parser-not-found ] , \ unless* , \ nip , ] [ ] make box ; : transform-ebnf ( string -- object ) @@ -340,10 +340,13 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) parse-result-ast transform dup dup parser [ main swap at compile ] with-variable [ compiled-parse ] curry [ with-scope ] curry ; -: [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing +: replace-escapes ( string -- string ) + "\\t" token [ drop "\t" ] action "\\n" token [ drop "\n" ] action 2choice replace ; + +: [EBNF "EBNF]" parse-multiline-string replace-escapes ebnf>quot nip parsed ; parsing : EBNF: CREATE-WORD dup - ";EBNF" parse-multiline-string + ";EBNF" parse-multiline-string replace-escapes ebnf>quot swapd 1 1 define-declared "ebnf-parser" set-word-prop ; parsing diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 9e35c5b9be..ad821635d7 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -30,6 +30,14 @@ SYMBOL: fail SYMBOL: lrstack SYMBOL: heads +: delegates ( -- cache ) + \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ; + +: reset-pegs ( -- ) + H{ } clone \ delegates set-global ; + +reset-pegs + TUPLE: memo-entry ans pos ; C: memo-entry @@ -253,14 +261,6 @@ SYMBOL: id 1 id set-global 0 ] if* ; -: delegates ( -- cache ) - \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ; - -: reset-delegates ( -- ) - H{ } clone \ delegates set-global ; - -reset-delegates - : init-parser ( parser -- parser ) #! Set the delegate for the parser. Equivalent parsers #! get a delegate with the same id. @@ -590,7 +590,13 @@ PRIVATE> #! not a cached one. This is because the same box, #! compiled twice can have a different compiled word #! due to running at compile time. - box-parser construct-boa next-id f over set-delegate ; + #! 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 construct-boa next-id f over set-delegate [ ] action ; : PEG: (:) [ From ae623ff9249632872cc85c69ecf3ade2797a47d0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 1 Apr 2008 19:00:20 -0500 Subject: [PATCH 373/886] normalize-pathname prepends unicode prefix, (normalize-pathname) does not --- core/io/backend/backend.factor | 2 +- core/io/files/files-tests.factor | 6 ----- core/io/files/files.factor | 13 ++++++--- extra/editors/editors.factor | 2 +- extra/io/unix/files/files-tests.factor | 6 +++++ extra/io/windows/launcher/launcher.factor | 2 +- extra/io/windows/nt/files/files-tests.factor | 9 ++++--- extra/io/windows/nt/files/files.factor | 28 +++++--------------- 8 files changed, 32 insertions(+), 36 deletions(-) diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 6bcd448385..935b007dd5 100755 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -1,7 +1,7 @@ ! 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 init assocs ; +io.encodings.utf8 init assocs splitting ; IN: io.backend SYMBOL: io-backend diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 9920d8d25c..b4a7d44433 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -220,8 +220,6 @@ io.encodings.utf8 ; [ "/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 [ "/usr/lib" ] [ "/usr" "./lib" append-path ] unit-test [ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test [ "/lib" ] [ "/usr" "../lib" append-path ] unit-test @@ -239,9 +237,6 @@ io.encodings.utf8 ; [ "lib" ] [ "" "lib" append-path ] unit-test [ "lib" ] [ "" "./lib" append-path ] unit-test -[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test -[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test - [ "foo/bar/." parent-directory ] must-fail [ "foo/bar/./" parent-directory ] must-fail [ "foo/bar/baz/.." parent-directory ] must-fail @@ -263,5 +258,4 @@ io.encodings.utf8 ; [ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test [ t ] [ "resource:core" absolute-path? ] unit-test -[ t ] [ "/foo" absolute-path? ] unit-test [ f ] [ "" absolute-path? ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 099acb157e..d2142cc6f3 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -102,6 +102,7 @@ PRIVATE> : windows-absolute-path? ( path -- path ? ) { + { [ dup "\\\\?\\" head? ] [ t ] } { [ dup length 2 < ] [ f ] } { [ dup second CHAR: : = ] [ t ] } { [ t ] [ f ] } @@ -111,8 +112,8 @@ PRIVATE> { { [ dup empty? ] [ f ] } { [ dup "resource:" head? ] [ t ] } - { [ dup first path-separator? ] [ t ] } { [ windows? ] [ windows-absolute-path? ] } + { [ dup first path-separator? ] [ t ] } { [ t ] [ f ] } } cond nip ; @@ -126,6 +127,9 @@ PRIVATE> 2 tail left-trim-separators >r parent-directory r> append-path ] } + { [ over absolute-path? over first path-separator? and ] [ + >r 2 head r> append + ] } { [ t ] [ >r right-trim-separators "/" r> left-trim-separators 3append @@ -296,14 +300,17 @@ DEFER: copy-tree-into : temp-file ( name -- path ) temp-directory prepend-path ; -M: object normalize-pathname ( path -- path' ) +: (normalize-pathname) ( path -- path' ) "resource:" ?head [ left-trim-separators resource-path - normalize-pathname + (normalize-pathname) ] [ current-directory get prepend-path ] if ; +M: object normalize-pathname ( path -- path' ) + (normalize-pathname) ; + ! Pathname presentations TUPLE: pathname string ; diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index c442dfaa94..00e20de5b5 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -26,7 +26,7 @@ SYMBOL: edit-hook require ; : edit-location ( file line -- ) - >r normalize-pathname "\\\\?\\" ?head drop r> + >r (normalize-pathname) "\\\\?\\" ?head drop r> edit-hook get [ call ] [ no-edit-hook edit-location ] if* ; : edit ( defspec -- ) diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor index bb2039adfb..a0310a1cac 100755 --- a/extra/io/unix/files/files-tests.factor +++ b/extra/io/unix/files/files-tests.factor @@ -21,3 +21,9 @@ IN: io.unix.files.tests [ "/lib/" ] [ "/" "../lib/" append-path ] unit-test [ "/lib" ] [ "/" "../../lib" append-path ] unit-test [ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test + +{ [ "/lib" ] [ "/usr/" "/lib" append-path ] } +{ [ "/lib/" ] [ "/usr/" "/lib/" append-path ] } +{ [ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] } +{ [ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] } +{ [ t ] [ "/foo" absolute-path? ] } diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 31247e43c3..f3226bfbf0 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -28,7 +28,7 @@ TUPLE: CreateProcess-args "PROCESS_INFORMATION" >>lpProcessInformation TRUE >>bInheritHandles 0 >>dwCreateFlags - current-directory get normalize-pathname >>lpCurrentDirectory ; + current-directory get (normalize-pathname) >>lpCurrentDirectory ; : call-CreateProcess ( CreateProcess-args -- ) { diff --git a/extra/io/windows/nt/files/files-tests.factor b/extra/io/windows/nt/files/files-tests.factor index 73d6a0bf7f..431aced65d 100644 --- a/extra/io/windows/nt/files/files-tests.factor +++ b/extra/io/windows/nt/files/files-tests.factor @@ -1,9 +1,9 @@ USING: io.files kernel tools.test io.backend -io.windows.nt.files splitting ; +io.windows.nt.files splitting sequences ; IN: io.windows.nt.files.tests -[ t ] [ "\\foo" absolute-path? ] unit-test -[ t ] [ "\\\\?\\foo" absolute-path? ] unit-test +[ 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 @@ -45,3 +45,6 @@ IN: io.windows.nt.files.tests "C:\\builds\\factor\\12345\\" "..\\.." append-path normalize-pathname ] unit-test + +[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test +[ t ] [ "" resource-path 2 tail exists? ] unit-test diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 81112a89c0..bc676b8d0a 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -36,28 +36,14 @@ ERROR: not-absolute-path ; } && [ 2 head ] [ not-absolute-path ] if ; : prepend-prefix ( string -- string' ) - unicode-prefix prepend ; + dup unicode-prefix head? [ + unicode-prefix prepend + ] unless ; -ERROR: nonstring-pathname ; -ERROR: empty-pathname ; - -M: windows-nt-io normalize-pathname ( string -- string ) - "resource:" ?head [ - left-trim-separators resource-path - normalize-pathname - ] [ - dup empty? [ empty-pathname ] when - current-directory get prepend-path - dup unicode-prefix head? [ - dup first path-separator? [ - left-trim-separators - current-directory get 2 head - prepend-path - ] when - unicode-prefix prepend - ] unless - { { CHAR: / CHAR: \\ } } substitute ! necessary - ] if ; +M: windows-nt-io normalize-pathname ( string -- string' ) + (normalize-pathname) + { { CHAR: / CHAR: \\ } } substitute + prepend-prefix ; M: windows-nt-io CreateFile-flags ( DWORD -- DWORD ) FILE_FLAG_OVERLAPPED bitor ; From 5ecb754cc863eca4f52e2d8a19edb20c78a8b85f Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 1 Apr 2008 18:18:18 -0600 Subject: [PATCH 374/886] newfx: mutators --- extra/newfx/newfx.factor | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index a5db87ca37..53cda66dfc 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -17,9 +17,16 @@ IN: newfx ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: nth-is ( seq i val -- seq ) swap pick set-nth ; +: nth-is ( seq i val -- seq ) swap pick set-nth ; +: is-nth ( seq val i -- seq ) pick set-nth ; -: is-nth ( seq val i -- seq ) pick set-nth ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: mutate-nth ( seq i val -- ) swap rot set-nth ; +: mutate-at-nth ( seq val i -- ) rot set-nth ; + +: mutate-nth-of ( i val seq -- ) swapd set-nth ; +: mutate-at-nth-of ( val i seq -- ) set-nth ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -33,6 +40,14 @@ IN: newfx ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: mutate-key ( tbl key val -- ) swap rot set-at ; +: mutate-at-key ( tbl val key -- ) rot set-at ; + +: mutate-key-of ( key val tbl -- ) swapd set-at ; +: mutate-at-key-of ( val key tbl -- ) set-at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : push ( seq obj -- seq ) over sequences:push ; : push-on ( obj seq -- seq ) tuck sequences:push ; @@ -48,3 +63,6 @@ IN: newfx ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! 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 From 1b58ba404ec22cef9d8713369c6aa4fa47387864 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 2 Apr 2008 13:50:29 +1300 Subject: [PATCH 375/886] Fix peg.pl0 test failures --- extra/peg/pl0/pl0-tests.factor | 47 +++++++++++++++++++++++++++++++++- extra/peg/pl0/pl0.factor | 26 ++++++++++--------- 2 files changed, 60 insertions(+), 13 deletions(-) diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor index b3d2135da7..1ed528d05d 100644 --- a/extra/peg/pl0/pl0-tests.factor +++ b/extra/peg/pl0/pl0-tests.factor @@ -1,9 +1,54 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel tools.test peg peg.pl0 multiline sequences ; +USING: kernel tools.test peg peg.pl0 multiline sequences words assocs ; IN: peg.pl0.tests +{ f } [ + "CONST foo = 1;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not +] unit-test + +{ f } [ + "VAR foo;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not +] unit-test + +{ f } [ + "VAR foo,bar , baz;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not +] unit-test + +{ f } [ + "foo := 5;" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not +] unit-test + +{ f } [ + "BEGIN foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not +] unit-test + +{ f } [ + "IF 1=1 THEN foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not +] unit-test + +{ f } [ + "WHILE 1=1 DO foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not +] unit-test + +{ f } [ + "WHILE ODD 1=1 DO foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not +] unit-test + +{ f } [ + "PROCEDURE square; BEGIN squ=x*x END" \ pl0 "ebnf-parser" word-prop "block" swap at parse not +] unit-test + +{ f } [ + <" +PROCEDURE square; +BEGIN + squ := x * x +END; +"> \ pl0 "ebnf-parser" word-prop "block" swap at parse not +] unit-test + { t } [ <" VAR x, squ; diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor index f7eb3cad23..8025728285 100644 --- a/extra/peg/pl0/pl0.factor +++ b/extra/peg/pl0/pl0.factor @@ -7,18 +7,20 @@ IN: peg.pl0 #! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0 EBNF: pl0 -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 ")" +- = (" " | "\t" | "\n")+ => [[ drop ignore ]] +_ = (" " | "\t" | "\n")* => [[ drop ignore ]] +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 _ ")" ident = (([a-zA-Z])+) [[ >string ]] digit = ([0-9]) [[ digit> ]] number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]] From 2bad7228a7df0496b240c2b4b5f7483b06b0d10e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 1 Apr 2008 19:51:49 -0500 Subject: [PATCH 376/886] rename normalize-pathname to normalize-path fix windows launcher issue --- core/io/backend/backend-tests.factor | 8 ++-- core/io/backend/backend.factor | 4 +- core/io/files/files-docs.factor | 2 +- core/io/files/files.factor | 45 ++++++++++---------- extra/cairo/png/png.factor | 2 +- extra/editors/editors.factor | 2 +- extra/io/sockets/sockets.factor | 2 +- extra/io/unix/files/files.factor | 20 ++++----- extra/io/unix/launcher/launcher.factor | 2 +- extra/io/windows/ce/files/files.factor | 2 +- extra/io/windows/files/files.factor | 8 ++-- extra/io/windows/launcher/launcher.factor | 2 +- extra/io/windows/nt/files/files-tests.factor | 8 ++-- extra/io/windows/nt/files/files.factor | 4 +- extra/io/windows/nt/launcher/launcher.factor | 2 +- extra/io/windows/windows.factor | 12 +++--- 16 files changed, 63 insertions(+), 62 deletions(-) mode change 100644 => 100755 core/io/backend/backend-tests.factor mode change 100644 => 100755 extra/io/windows/nt/files/files-tests.factor diff --git a/core/io/backend/backend-tests.factor b/core/io/backend/backend-tests.factor old mode 100644 new mode 100755 index 04f34068eb..c3d7e8e89b --- a/core/io/backend/backend-tests.factor +++ b/core/io/backend/backend-tests.factor @@ -1,4 +1,4 @@ -IN: io.backend.tests -USING: tools.test io.backend kernel ; - -[ ] [ "a" normalize-pathname drop ] unit-test +IN: io.backend.tests +USING: tools.test io.backend kernel ; + +[ ] [ "a" normalize-path drop ] unit-test diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 935b007dd5..44b1eea349 100755 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -18,9 +18,9 @@ HOOK: io-multiplex io-backend ( ms -- ) HOOK: normalize-directory io-backend ( str -- newstr ) -HOOK: normalize-pathname io-backend ( str -- newstr ) +HOOK: normalize-path io-backend ( str -- newstr ) -M: object normalize-directory normalize-pathname ; +M: object normalize-directory normalize-path ; : set-io-backend ( io-backend -- ) io-backend set-global init-io init-stdio diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 1953569223..342967acfc 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -252,7 +252,7 @@ HELP: normalize-directory { $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 words such as " { $link } " and " { $link } " to prepare a pathname before passing it to underlying code." } ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index d2142cc6f3..720894d489 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -13,13 +13,13 @@ HOOK: (file-writer) io-backend ( path -- stream ) HOOK: (file-appender) io-backend ( path -- stream ) : ( path encoding -- stream ) - swap normalize-pathname (file-reader) swap ; + swap normalize-path (file-reader) swap ; : ( path encoding -- stream ) - swap normalize-pathname (file-writer) swap ; + swap normalize-path (file-writer) swap ; : ( path encoding -- stream ) - swap normalize-pathname (file-appender) swap ; + swap normalize-path (file-appender) swap ; : file-lines ( path encoding -- seq ) lines ; @@ -171,7 +171,7 @@ SYMBOL: +unknown+ ! File metadata : exists? ( path -- ? ) - normalize-pathname (exists?) ; + normalize-path (exists?) ; : directory? ( path -- ? ) file-info file-info-type +directory+ = ; @@ -187,18 +187,33 @@ M: object cwd ( -- path ) "." ; [ 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) ; + : with-directory ( path quot -- ) - >r normalize-pathname r> + >r (normalize-path) r> current-directory swap with-variable ; inline : set-current-directory ( path -- ) - normalize-pathname current-directory set ; + normalize-path current-directory set ; ! 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? ] [ ] } @@ -271,7 +286,7 @@ M: object copy-file DEFER: copy-tree-into : copy-tree ( from to -- ) - normalize-pathname + normalize-path over link-info type>> { { +symbolic-link+ [ copy-link ] } @@ -290,9 +305,6 @@ DEFER: copy-tree-into [ copy-tree-into ] curry each ; ! Special paths -: resource-path ( path -- newpath ) - "resource-path" get [ image parent-directory ] unless* - prepend-path ; : temp-directory ( -- path ) "temp" resource-path dup make-directories ; @@ -300,17 +312,6 @@ DEFER: copy-tree-into : temp-file ( name -- path ) temp-directory prepend-path ; -: (normalize-pathname) ( path -- path' ) - "resource:" ?head [ - left-trim-separators resource-path - (normalize-pathname) - ] [ - current-directory get prepend-path - ] if ; - -M: object normalize-pathname ( path -- path' ) - (normalize-pathname) ; - ! Pathname presentations TUPLE: pathname string ; diff --git a/extra/cairo/png/png.factor b/extra/cairo/png/png.factor index 774a1afe8e..f9908e4581 100755 --- a/extra/cairo/png/png.factor +++ b/extra/cairo/png/png.factor @@ -24,7 +24,7 @@ ERROR: cairo-error string ; } cond ; : ( path -- png ) - normalize-pathname + normalize-path cairo_image_surface_create_from_png dup cairo_surface_status cairo-png-error dup [ cairo_image_surface_get_width check-zero ] diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index 00e20de5b5..e871d5f808 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -26,7 +26,7 @@ SYMBOL: edit-hook require ; : edit-location ( file line -- ) - >r (normalize-pathname) "\\\\?\\" ?head drop r> + >r (normalize-path) "\\\\?\\" ?head drop r> edit-hook get [ call ] [ no-edit-hook edit-location ] if* ; : edit ( defspec -- ) diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index e1cc36cd2e..17799227b8 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -7,7 +7,7 @@ IN: io.sockets TUPLE: local path ; : ( path -- addrspec ) - normalize-pathname local construct-boa ; + normalize-path local construct-boa ; TUPLE: inet4 host port ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index c4e506d37f..7d0e7c4330 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -43,22 +43,22 @@ M: unix-io (file-appender) ( path -- stream ) { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable M: unix-io touch-file ( path -- ) - normalize-pathname + 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 -- ) - [ normalize-pathname ] bi@ rename io-error ; + [ normalize-path ] bi@ rename io-error ; M: unix-io delete-file ( path -- ) - normalize-pathname unlink io-error ; + normalize-path unlink io-error ; M: unix-io make-directory ( path -- ) - normalize-pathname OCT: 777 mkdir io-error ; + normalize-path OCT: 777 mkdir io-error ; M: unix-io delete-directory ( path -- ) - normalize-pathname rmdir io-error ; + normalize-path rmdir io-error ; : (copy-file) ( from to -- ) dup parent-directory make-directories @@ -69,7 +69,7 @@ M: unix-io delete-directory ( path -- ) ] with-disposal ; M: unix-io copy-file ( from to -- ) - [ normalize-pathname ] bi@ + [ normalize-path ] bi@ [ (copy-file) ] [ swap file-info file-info-permissions chmod io-error ] 2bi ; @@ -96,15 +96,15 @@ M: unix-io copy-file ( from to -- ) \ file-info construct-boa ; M: unix-io file-info ( path -- info ) - normalize-pathname stat* stat>file-info ; + normalize-path stat* stat>file-info ; M: unix-io link-info ( path -- info ) - normalize-pathname lstat* stat>file-info ; + normalize-path lstat* stat>file-info ; M: unix-io make-link ( path1 path2 -- ) - normalize-pathname symlink io-error ; + normalize-path symlink io-error ; M: unix-io read-link ( path -- path' ) - normalize-pathname + normalize-path PATH_MAX [ tuck ] [ ] bi readlink dup io-error head-slice >string ; diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index f738bd42c2..4986024e78 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -37,7 +37,7 @@ USE: unix 2nip reset-fd ; : redirect-file ( obj mode fd -- ) - >r >r normalize-pathname r> file-mode + >r >r normalize-path r> file-mode open dup io-error r> redirect-fd ; : redirect-closed ( obj mode fd -- ) diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor index c4f5b2ef9e..1e5cedae57 100755 --- a/extra/io/windows/ce/files/files.factor +++ b/extra/io/windows/ce/files/files.factor @@ -4,7 +4,7 @@ prettyprint sequences strings threads threads.private windows windows.kernel32 io.windows.ce.backend ; IN: windows.ce.files -! M: windows-ce-io normalize-pathname ( string -- string ) +! M: windows-ce-io normalize-path ( string -- string ) ! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ; M: windows-ce-io CreateFile-flags ( DWORD -- DWORD ) diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index 295b3ab006..a23a78b3da 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -89,14 +89,14 @@ SYMBOLS: +read-only+ +hidden+ +system+ ] if ; M: windows-nt-io file-info ( path -- info ) - normalize-pathname get-file-information-stat ; + normalize-path get-file-information-stat ; M: windows-nt-io link-info ( path -- info ) file-info ; : file-times ( path -- timestamp timestamp timestamp ) [ - normalize-pathname open-existing dup close-always + normalize-path open-existing dup close-always "FILETIME" "FILETIME" "FILETIME" @@ -112,7 +112,7 @@ M: windows-nt-io link-info ( path -- info ) #! timestamp order: creation access write [ >r >r >r - normalize-pathname open-existing dup close-always + normalize-path open-existing dup close-always r> r> r> (set-file-times) ] with-destructors ; @@ -127,7 +127,7 @@ M: windows-nt-io link-info ( path -- info ) M: windows-nt-io touch-file ( path -- ) [ - normalize-pathname + normalize-path maybe-create-file over close-always [ drop ] [ f now dup (set-file-times) ] if ] with-destructors ; diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index f3226bfbf0..579745710e 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -28,7 +28,7 @@ TUPLE: CreateProcess-args "PROCESS_INFORMATION" >>lpProcessInformation TRUE >>bInheritHandles 0 >>dwCreateFlags - current-directory get (normalize-pathname) >>lpCurrentDirectory ; + current-directory get (normalize-path) >>lpCurrentDirectory ; : call-CreateProcess ( CreateProcess-args -- ) { diff --git a/extra/io/windows/nt/files/files-tests.factor b/extra/io/windows/nt/files/files-tests.factor old mode 100644 new mode 100755 index 431aced65d..1e6268fbc0 --- a/extra/io/windows/nt/files/files-tests.factor +++ b/extra/io/windows/nt/files/files-tests.factor @@ -29,21 +29,21 @@ IN: io.windows.nt.files.tests [ ] [ "" resource-path cd ] unit-test -[ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] 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-pathname + "..\\log.txt" append-path normalize-path ] unit-test [ "\\\\?\\C:\\builds\\" ] [ "C:\\builds\\factor\\12345\\" - "..\\.." append-path normalize-pathname + "..\\.." append-path normalize-path ] unit-test [ "\\\\?\\C:\\builds\\" ] [ "C:\\builds\\factor\\12345\\" - "..\\.." append-path normalize-pathname + "..\\.." append-path normalize-path ] unit-test [ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index bc676b8d0a..91ad0139b2 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -40,8 +40,8 @@ ERROR: not-absolute-path ; unicode-prefix prepend ] unless ; -M: windows-nt-io normalize-pathname ( string -- string' ) - (normalize-pathname) +M: windows-nt-io normalize-path ( string -- string' ) + (normalize-path) { { CHAR: / CHAR: \\ } } substitute prepend-prefix ; diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index c342b2ee9a..895890e898 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -32,7 +32,7 @@ IN: io.windows.nt.launcher 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 diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 27917cedfa..45c1adaf50 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -25,7 +25,7 @@ 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 ; + normalize-path "\\" ?tail drop "\\*" append ; : share-mode ( -- fixnum ) { @@ -135,21 +135,21 @@ M: windows-io (file-appender) ( path -- stream ) open-append ; M: windows-io move-file ( from to -- ) - [ normalize-pathname ] bi@ MoveFile win32-error=0/f ; + [ normalize-path ] bi@ MoveFile win32-error=0/f ; M: windows-io delete-file ( path -- ) - normalize-pathname DeleteFile win32-error=0/f ; + normalize-path DeleteFile win32-error=0/f ; M: windows-io copy-file ( from to -- ) dup parent-directory make-directories - [ normalize-pathname ] bi@ 0 CopyFile win32-error=0/f ; + [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ; M: windows-io make-directory ( path -- ) - normalize-pathname + normalize-path f CreateDirectory win32-error=0/f ; M: windows-io delete-directory ( path -- ) - normalize-pathname + normalize-path RemoveDirectory win32-error=0/f ; HOOK: WSASocket-flags io-backend ( -- DWORD ) From 8047115746ada0a5577e8e045140a8424441005b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 1 Apr 2008 18:52:40 -0600 Subject: [PATCH 377/886] remove extra/new-effects --- extra/new-effects/new-effects.factor | 17 ----------------- 1 file changed, 17 deletions(-) delete mode 100644 extra/new-effects/new-effects.factor diff --git a/extra/new-effects/new-effects.factor b/extra/new-effects/new-effects.factor deleted file mode 100644 index f073ccadd3..0000000000 --- a/extra/new-effects/new-effects.factor +++ /dev/null @@ -1,17 +0,0 @@ -USING: assocs kernel sequences ; -IN: new-effects - -: new-nth ( seq n -- elt ) - swap nth ; inline - -: new-set-nth ( seq obj n -- seq ) - pick set-nth ; inline - -: new-at ( assoc key -- elt ) - swap at ; inline - -: new-at* ( assoc key -- elt ? ) - swap at* ; inline - -: new-set-at ( assoc value key -- assoc ) - pick set-at ; inline From a94e5245a3b35d6062990729e16b8bf13d2a4cdd Mon Sep 17 00:00:00 2001 From: erg Date: Tue, 1 Apr 2008 20:07:18 -0500 Subject: [PATCH 378/886] fix teh tests FOR GREAT JUSTICE --- extra/io/unix/files/files-tests.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor index a0310a1cac..040b191d27 100755 --- a/extra/io/unix/files/files-tests.factor +++ b/extra/io/unix/files/files-tests.factor @@ -22,8 +22,8 @@ IN: io.unix.files.tests [ "/lib" ] [ "/" "../../lib" append-path ] unit-test [ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test -{ [ "/lib" ] [ "/usr/" "/lib" append-path ] } -{ [ "/lib/" ] [ "/usr/" "/lib/" append-path ] } -{ [ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] } -{ [ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] } -{ [ t ] [ "/foo" absolute-path? ] } +[ "/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 From 6ac0d4692fee4a81fef062a9738f1030abee6ae6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 1 Apr 2008 20:20:13 -0500 Subject: [PATCH 379/886] remove wrap word, add circular to mersenne twister --- extra/random/mersenne-twister/mersenne-twister.factor | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index 8ddbdac6f4..77054ea377 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -4,7 +4,7 @@ ! 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 ; +accessors math.ranges random circular ; IN: random.mersenne-twister = [ - ] [ drop ] if ; inline -: mt-wrap ( x -- y ) mt-n wrap ; inline : set-generated ( y from-elt to seq -- ) >r >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi @@ -27,8 +25,8 @@ TUPLE: mersenne-twister seq i ; tuck [ nth mt-hi ] [ nth mt-lo ] 2bi* bitor ; inline : (mt-generate) ( n mt-seq -- y to from-elt ) - [ >r dup 1+ mt-wrap r> calculate-y ] - [ >r mt-m + mt-wrap r> nth ] + [ >r dup 1+ r> calculate-y ] + [ >r mt-m + r> nth ] [ drop ] 2tri ; : mt-generate ( mt -- ) @@ -36,7 +34,7 @@ TUPLE: mersenne-twister seq i ; [ 0 >>i drop ] bi ; : init-mt-first ( seed -- seq ) - >r mt-n 0 r> + >r mt-n 0 r> HEX: ffffffff bitand 0 pick set-nth ; : init-mt-formula ( seq i -- f(seq[i]) ) From bbcc84862f5e2ee038011886b330c3c655e754d4 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 2 Apr 2008 15:47:21 +1300 Subject: [PATCH 380/886] Tweak ast from sequences in ebnf --- extra/peg/ebnf/ebnf.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index a4e4fe387d..7c5854cd7d 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -252,7 +252,7 @@ M: ebnf-rule (transform) ( ast -- parser ) ] keep ; M: ebnf-sequence (transform) ( ast -- parser ) - elements>> [ (transform) ] map seq ; + elements>> [ (transform) ] map seq [ dup length 1 = [ first ] when ] action ; M: ebnf-choice (transform) ( ast -- parser ) options>> [ (transform) ] map choice ; From 34a1505d95891fd516e4f5b176d937fe4641dd8a Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 2 Apr 2008 15:47:30 +1300 Subject: [PATCH 381/886] PL0 whitespace handling improvement --- extra/peg/pl0/pl0-tests.factor | 36 +++++++++---------- extra/peg/pl0/pl0.factor | 64 +++++++++++++++++++++++++--------- 2 files changed, 65 insertions(+), 35 deletions(-) diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor index 1ed528d05d..039f66637d 100644 --- a/extra/peg/pl0/pl0-tests.factor +++ b/extra/peg/pl0/pl0-tests.factor @@ -4,40 +4,40 @@ USING: kernel tools.test peg peg.pl0 multiline sequences words assocs ; IN: peg.pl0.tests -{ f } [ - "CONST foo = 1;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not +{ t } [ + "CONST foo = 1;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty? ] unit-test -{ f } [ - "VAR foo;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not +{ t } [ + "VAR foo;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty? ] unit-test -{ f } [ - "VAR foo,bar , baz;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not +{ t } [ + "VAR foo,bar , baz;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty? ] unit-test -{ f } [ - "foo := 5;" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not +{ t } [ + "foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty? ] unit-test -{ f } [ - "BEGIN foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not +{ t } [ + "BEGIN foo := 5 END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty? ] unit-test -{ f } [ - "IF 1=1 THEN foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not +{ t } [ + "IF 1=1 THEN foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty? ] unit-test -{ f } [ - "WHILE 1=1 DO foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not +{ t } [ + "WHILE 1=1 DO foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty? ] unit-test -{ f } [ - "WHILE ODD 1=1 DO foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not +{ t } [ + "WHILE ODD 1 DO foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty? ] unit-test -{ f } [ - "PROCEDURE square; BEGIN squ=x*x END" \ pl0 "ebnf-parser" word-prop "block" swap at parse not +{ t } [ + "PROCEDURE square; BEGIN squ:=x*x END" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty? ] unit-test { f } [ diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor index 8025728285..1b97814ca7 100644 --- a/extra/peg/pl0/pl0.factor +++ b/extra/peg/pl0/pl0.factor @@ -7,22 +7,52 @@ IN: peg.pl0 #! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0 EBNF: pl0 -- = (" " | "\t" | "\n")+ => [[ drop ignore ]] _ = (" " | "\t" | "\n")* => [[ drop ignore ]] -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 _ ")" -ident = (([a-zA-Z])+) [[ >string ]] -digit = ([0-9]) [[ digit> ]] -number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]] -program = block "." + +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 From eac450bdcf28773813552170bd1091e13148202b Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 2 Apr 2008 15:55:18 +1300 Subject: [PATCH 382/886] Add ebnf rule word --- extra/peg/ebnf/ebnf.factor | 3 +++ extra/peg/pl0/pl0-tests.factor | 29 ++++++++++------------------- 2 files changed, 13 insertions(+), 19 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 7c5854cd7d..b0dfaad5b3 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -350,3 +350,6 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) ";EBNF" parse-multiline-string replace-escapes ebnf>quot swapd 1 1 define-declared "ebnf-parser" set-word-prop ; parsing +: rule ( name word -- parser ) + #! Given an EBNF word produced from EBNF: return the EBNF rule + "ebnf-parser" word-prop at ; \ No newline at end of file diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor index 039f66637d..88993c354b 100644 --- a/extra/peg/pl0/pl0-tests.factor +++ b/extra/peg/pl0/pl0-tests.factor @@ -1,52 +1,43 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel tools.test peg peg.pl0 multiline sequences words assocs ; +USING: kernel tools.test peg peg.ebnf peg.pl0 multiline sequences ; IN: peg.pl0.tests { t } [ - "CONST foo = 1;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty? + "CONST foo = 1;" "block" \ pl0 rule parse parse-result-remaining empty? ] unit-test { t } [ - "VAR foo;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty? + "VAR foo;" "block" \ pl0 rule parse parse-result-remaining empty? ] unit-test { t } [ - "VAR foo,bar , baz;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty? + "VAR foo,bar , baz;" "block" \ pl0 rule parse parse-result-remaining empty? ] unit-test { t } [ - "foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty? + "foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty? ] unit-test { t } [ - "BEGIN foo := 5 END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty? + "BEGIN foo := 5 END" "statement" \ pl0 rule parse parse-result-remaining empty? ] unit-test { t } [ - "IF 1=1 THEN foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty? + "IF 1=1 THEN foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty? ] unit-test { t } [ - "WHILE 1=1 DO foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty? + "WHILE 1=1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty? ] unit-test { t } [ - "WHILE ODD 1 DO foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty? + "WHILE ODD 1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty? ] unit-test { t } [ - "PROCEDURE square; BEGIN squ:=x*x END" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty? -] unit-test - -{ f } [ - <" -PROCEDURE square; -BEGIN - squ := x * x -END; -"> \ pl0 "ebnf-parser" word-prop "block" swap at parse not + "PROCEDURE square; BEGIN squ:=x*x END" "block" \ pl0 rule parse parse-result-remaining empty? ] unit-test { t } [ From b085ce2f5ff236eeae7640fcd75c34a189648cab Mon Sep 17 00:00:00 2001 From: erg Date: Tue, 1 Apr 2008 22:24:00 -0500 Subject: [PATCH 383/886] fix unit test --- extra/classes/singleton/singleton-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/classes/singleton/singleton-tests.factor b/extra/classes/singleton/singleton-tests.factor index 08f4a77aad..586724ee3b 100644 --- a/extra/classes/singleton/singleton-tests.factor +++ b/extra/classes/singleton/singleton-tests.factor @@ -9,4 +9,4 @@ GENERIC: zammo ( obj -- ) [ "yes!" ] [ bzzt zammo ] unit-test [ ] [ SINGLETON: omg ] unit-test [ t ] [ omg singleton? ] unit-test -[ "USING: singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test +[ "USING: classes.singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test From a2971bd3bef5ed9fb3e1b6cf66141156aafd2c43 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 00:03:04 -0500 Subject: [PATCH 384/886] Improve walker: step into on an array recursively sets breakpoint on each quotation nested in the array. Useful for cond, case, cleave, ... --- extra/tools/walker/walker.factor | 44 ++++++++++++++++++++------------ 1 file changed, 28 insertions(+), 16 deletions(-) diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index d548c0a4f5..6bd8ace877 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -3,7 +3,7 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words -sequences.private assocs models ; +sequences.private assocs models arrays accessors ; IN: tools.walker SYMBOL: show-walker-hook ! ( status continuation thread -- ) @@ -51,9 +51,16 @@ DEFER: start-walker-thread : walk ( quot -- quot' ) \ break prefix [ break rethrow ] recover ; -: add-breakpoint ( quot -- quot' ) +GENERIC: add-breakpoint ( quot -- quot' ) + +M: callable add-breakpoint dup [ break ] head? [ \ break prefix ] unless ; +M: array add-breakpoint + [ add-breakpoint ] map ; + +M: object add-breakpoint ; + : (step-into-quot) ( quot -- ) add-breakpoint call ; : (step-into-if) ? (step-into-quot) ; @@ -74,7 +81,7 @@ DEFER: start-walker-thread \ (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 @@ -94,15 +101,18 @@ SYMBOL: +stopped+ : 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' ) [ @@ -143,6 +153,7 @@ SYMBOL: +stopped+ swap % unclip { { [ dup \ break eq? ] [ , ] } { [ dup quotation? ] [ add-breakpoint , \ break , ] } + { [ dup array? ] [ add-breakpoint , \ break , ] } { [ dup word? ] [ literalize , \ (step-into-execute) , ] } { [ t ] [ , \ break , ] } } cond % @@ -177,16 +188,17 @@ SYMBOL: +stopped+ { 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 From fa8b578370a8d23968225160c13634f9e95da8e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 00:28:07 -0500 Subject: [PATCH 385/886] Rewriting method dispatch to support inheritance --- core/bootstrap/layouts/layouts.factor | 4 +- core/bootstrap/primitives.factor | 23 ++- core/classes/classes.factor | 6 +- core/combinators/combinators.factor | 8 +- core/compiler/tests/intrinsics.factor | 8 - core/compiler/tests/templates.factor | 4 - core/cpu/x86/intrinsics/intrinsics.factor | 52 ------- core/generic/generic.factor | 8 +- core/generic/standard/engines/engines.factor | 49 ++++++ .../engines/predicate/predicate.factor | 28 ++++ core/generic/standard/engines/tag/tag.factor | 48 ++++++ .../standard/engines/tuple/tuple.factor | 109 ++++++++++++++ core/generic/standard/new/new-tests.factor | 141 ++++++++++++++++++ core/generic/standard/new/new.factor | 139 +++++++++++++++++ core/generic/standard/standard.factor | 24 +-- core/inference/backend/backend.factor | 15 +- core/inference/class/class-tests.factor | 2 +- core/inference/known-words/known-words.factor | 3 - core/kernel/kernel-docs.factor | 6 - core/kernel/kernel.factor | 10 +- core/layouts/layouts-docs.factor | 4 +- core/optimizer/known-words/known-words.factor | 23 --- 22 files changed, 573 insertions(+), 141 deletions(-) create mode 100644 core/generic/standard/engines/engines.factor create mode 100644 core/generic/standard/engines/predicate/predicate.factor create mode 100644 core/generic/standard/engines/tag/tag.factor create mode 100644 core/generic/standard/engines/tuple/tuple.factor create mode 100644 core/generic/standard/new/new-tests.factor create mode 100644 core/generic/standard/new/new.factor diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index 846cce153b..ceb011d52b 100755 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -2,7 +2,8 @@ ! 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 classes.tuple.private ; +float-arrays quotations assocs layouts classes.tuple.private +kernel.private ; BIN: 111 tag-mask set 8 num-tags set @@ -15,6 +16,7 @@ H{ { bignum BIN: 001 } { tuple BIN: 010 } { object BIN: 011 } + { hi-tag BIN: 011 } { ratio BIN: 100 } { float BIN: 101 } { complex BIN: 110 } diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index bc876c2dec..48a1117574 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -101,17 +101,24 @@ num-types get f builtins set } [ create-vocab drop ] each ! 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 - [ tag-mask get < \ tag \ type ? , ] [ , ] bi - \ 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 builtin-predicate-quot define-predicate ] - [ predicate-word make-inline ] - bi ; + dup builtin-predicate-quot define-predicate ; : lookup-type-number ( word -- n ) global [ target-word ] bind type-number ; @@ -363,7 +370,7 @@ define-class f builtins get [ ] subset union-class define-class ! Class of objects with object tag -"hi-tag" "classes.private" create +"hi-tag" "kernel.private" create f builtins get num-tags get tail union-class define-class ! Null class with no instances. diff --git a/core/classes/classes.factor b/core/classes/classes.factor index d6d1a72121..d91b1bb217 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -124,6 +124,8 @@ GENERIC: update-methods ( assoc -- ) ] bi ] 2tri ; -GENERIC: class ( object -- class ) inline +GENERIC: class ( object -- class ) -M: object class type type>class ; +M: hi-tag class hi-tag type>class ; + +M: object class tag type>class ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index f9ed219d7b..139c6d8fdf 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -9,24 +9,24 @@ hashtables sorting ; [ call ] with each ; : cleave>quot ( seq -- quot ) - [ [ keep ] curry ] map concat [ drop ] append ; + [ [ keep ] curry ] map concat [ drop ] append [ ] like ; : 2cleave ( x seq -- ) [ 2keep ] each 2drop ; : 2cleave>quot ( seq -- quot ) - [ [ 2keep ] curry ] map concat [ 2drop ] append ; + [ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ; : 3cleave ( x seq -- ) [ 3keep ] each 3drop ; : 3cleave>quot ( seq -- quot ) - [ [ 3keep ] curry ] map concat [ 3drop ] append ; + [ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ; : spread>quot ( seq -- quot ) [ length [ >r ] concat ] [ [ [ r> ] prepend ] map concat ] bi - append ; + append [ ] like ; : spread ( objs... seq -- ) spread>quot call ; diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index 7a8fe5d735..fadc57dc8d 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -174,11 +174,6 @@ sequences.private ; [ -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 @@ -223,9 +218,6 @@ sequences.private ; [ 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 3 100000 pick set-nth diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 081a8fd47c..a82208e9b9 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -26,10 +26,6 @@ IN: compiler.tests [ { 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 diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index 261ada025b..80a786c9fa 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -19,58 +19,6 @@ IN: cpu.x86.intrinsics { +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 diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 7dba7eb709..dc98883654 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -37,10 +37,12 @@ PREDICATE: method-spec < pair : order ( generic -- seq ) "methods" word-prop keys sort-classes ; +: sort-methods ( assoc -- assoc' ) + [ keys sort-classes ] + [ [ dupd at ] curry ] bi { } map>assoc ; + : methods ( word -- assoc ) - "methods" word-prop - [ keys sort-classes ] keep - [ dupd at ] curry { } map>assoc ; + "methods" word-prop sort-methods ; TUPLE: check-method class generic ; diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor new file mode 100644 index 0000000000..bf8d4fb67a --- /dev/null +++ b/core/generic/standard/engines/engines.factor @@ -0,0 +1,49 @@ +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) ; diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor new file mode 100644 index 0000000000..2d43a313f0 --- /dev/null +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -0,0 +1,28 @@ +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 + +: 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 ] } + { [ t ] [ [ first second ] [ 1 tail-slice ] bi ] } + } cond ; + +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 ; diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor new file mode 100644 index 0000000000..fd40af0e50 --- /dev/null +++ b/core/generic/standard/engines/tag/tag.factor @@ -0,0 +1,48 @@ +USING: classes.private generic.standard.engines namespaces +arrays mirrors assocs sequences.private quotations +kernel.private layouts math slots.private math.private +kernel accessors ; +IN: generic.standard.engines.tag + +TUPLE: lo-tag-dispatch-engine methods ; + +C: lo-tag-dispatch-engine + +TUPLE: hi-tag-dispatch-engine methods ; + +C: hi-tag-dispatch-engine + +: convert-hi-tag-methods ( assoc -- assoc' ) + hi-tag \ convert-methods ; + +: direct-dispatch-quot ( alist n -- quot ) + default get + [ swap update ] keep + [ dispatch ] curry >quotation ; + +M: lo-tag-dispatch-engine engine>quot + methods>> engines>quots* [ >r tag-number r> ] assoc-map + [ + picker % [ tag ] % [ + linear-dispatch-quot + ] [ + num-tags get direct-dispatch-quot + ] if-small? % + ] [ ] make ; + +: num-hi-tags num-types get num-tags get - ; + +: hi-tag-number type-number num-tags get - ; + +: hi-tag-quot ( -- quot ) + [ 0 slot ] num-tags get [ fixnum- ] 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 ; diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor new file mode 100644 index 0000000000..ce0f50337d --- /dev/null +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -0,0 +1,109 @@ +IN: generic.standard.engines.tuple +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 quotations ; + +TUPLE: echelon-dispatch-engine n methods ; + +C: echelon-dispatch-engine + +TUPLE: trivial-tuple-dispatch-engine methods ; + +C: trivial-tuple-dispatch-engine + +TUPLE: tuple-dispatch-engine echelons ; + +: push-echelon ( class method assoc -- ) + >r swap dup tuple-layout layout-echelon r> + [ ?set-at ] change-at ; + +: echelon-sort ( assoc -- assoc' ) + V{ } clone [ + [ + push-echelon + ] curry assoc-each + ] keep sort-keys ; + +: ( methods -- engine ) + echelon-sort + [ dupd ] assoc-map + \ tuple-dispatch-engine construct-boa ; + +: convert-tuple-methods ( assoc -- assoc' ) + tuple \ convert-methods ; + +M: trivial-tuple-dispatch-engine engine>quot + methods>> engines>quots* linear-dispatch-quot ; + +: hash-methods ( methods -- buckets ) + >alist V{ } clone [ class-hashes ] distribute-buckets + [ ] map ; + +: class-hash-dispatch-quot ( methods -- quot ) + #! 1 slot == word hashcode + [ + [ dup 1 slot ] % + hash-methods [ engine>quot ] map hash-dispatch-quot % + ] [ ] make ; + +: tuple-dispatch-engine-word-name ( engine -- string ) + [ + generic get word-name % + "/tuple-dispatch-engine/" % + n>> # + ] "" make ; + +PREDICATE: tuple-dispatch-engine-word < word + "tuple-dispatch-engine" word-prop ; + +M: tuple-dispatch-engine-word stack-effect + "tuple-dispatch-generic" word-prop stack-effect ; + +: ( engine -- word ) + tuple-dispatch-engine-word-name f + [ t "tuple-dispatch-engine" set-word-prop ] + [ generic get "tuple-dispatch-generic" set-word-prop ] + [ ] + tri ; + +: define-tuple-dispatch-engine-word ( engine quot -- word ) + >r dup r> define ; + +: tuple-dispatch-engine-body ( engine -- quot ) + #! 1 slot == tuple-layout + #! 2 slot == 0 array-nth + #! 4 slot == layout-superclasses + [ + picker % + [ 1 slot 4 slot ] % + [ n>> 2 + , [ slot ] % ] + [ + methods>> [ + engine>quot + ] [ + class-hash-dispatch-quot + ] if-small? % + ] bi + ] [ ] make ; + +M: echelon-dispatch-engine engine>quot + dup tuple-dispatch-engine-body + define-tuple-dispatch-engine-word + 1quotation ; + +: >=-case-quot ( alist -- quot ) + default get [ drop ] prepend swap + [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map + alist>quot ; + +M: tuple-dispatch-engine engine>quot + #! 1 slot == tuple-layout + #! 5 slot == layout-echelon + [ + picker % + [ 1 slot 5 slot ] % + echelons>> + [ [ engine>quot dup default set ] assoc-map ] with-scope + >=-case-quot % + ] [ ] make ; diff --git a/core/generic/standard/new/new-tests.factor b/core/generic/standard/new/new-tests.factor new file mode 100644 index 0000000000..d372926f43 --- /dev/null +++ b/core/generic/standard/new/new-tests.factor @@ -0,0 +1,141 @@ +IN: generic.standard.new.tests +USING: tools.test math math.functions math.constants +generic.standard.new strings sequences arrays kernel accessors +words float-arrays byte-arrays bit-arrays parser ; + +<< : GENERIC: CREATE-GENERIC define-simple-generic ; parsing >> + +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: number 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 + +TUPLE: parallelogram < abstract-rectangle skew ; + +C: parallelogram + +TUPLE: circle < shape radius ; + +C: circle + +GENERIC: area + +M: abstract-rectangle area [ width>> ] [ height>> ] bi * ; + +M: circle area radius>> sq pi * ; + +[ 12 ] [ 4 3 area ] unit-test +[ 12 ] [ 4 3 2 area ] unit-test +[ t ] [ 2 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 perimiter ] unit-test +[ 30 ] [ 10 4 3 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 big-mix-test ] unit-test +[ "parallelogram" ] [ 10 4 3 big-mix-test ] unit-test +[ "circle" ] [ 100 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 diff --git a/core/generic/standard/new/new.factor b/core/generic/standard/new/new.factor new file mode 100644 index 0000000000..b2371cc4e5 --- /dev/null +++ b/core/generic/standard/new/new.factor @@ -0,0 +1,139 @@ +! Copyright (C) 2005, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays assocs kernel kernel.private slots.private math +namespaces sequences vectors words quotations definitions +hashtables layouts combinators sequences.private generic +classes classes.algebra classes.private generic.standard.engines +generic.standard.engines.tag generic.standard.engines.predicate +generic.standard.engines.tuple accessors ; +IN: generic.standard.new + +: unpickers + { + [ nip ] + [ >r nip r> swap ] + [ >r >r nip r> r> -rot ] + } ; inline + +: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ; + +ERROR: no-method object generic ; + +: error-method ( word -- quot ) + picker swap [ no-method ] curry append ; + +: empty-method ( word -- quot ) + [ + picker % [ delegate dup ] % + unpicker over suffix , + error-method \ drop prefix , \ if , + ] [ ] make ; + +: default-method ( word -- pair ) + "default-method" word-prop + object bootstrap-word swap 2array ; + +: push-method ( method specializer atomic assoc -- ) + [ + [ H{ } clone ] 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 ; + +: ( assoc -- engine ) + flatten-methods + convert-tuple-methods + convert-hi-tag-methods + ; + +: find-default ( methods -- quot ) + #! Side-effects methods. + object swap delete-at* [ + drop generic get "default-method" word-prop + ] unless 1quotation ; + +GENERIC: mangle-method ( method generic -- quot ) + +: single-combination ( words -- quot ) + [ + object bootstrap-word assumed set + [ generic set ] + [ + "methods" word-prop + [ generic get mangle-method ] assoc-map + [ find-default default set ] + [ + generic get "inline" word-prop [ + + ] [ + + ] if + ] bi + engine>quot + ] bi + ] with-scope ; + +TUPLE: standard-combination # ; + +C: standard-combination + +PREDICATE: standard-generic < generic + "combination" word-prop standard-combination? ; + +PREDICATE: simple-generic < standard-generic + "combination" word-prop #>> zero? ; + +: define-simple-generic ( word -- ) + T{ standard-combination f 0 } define-generic ; + +: with-standard ( combination quot -- quot' ) + >r #>> (dispatch#) r> with-variable ; + +M: standard-combination make-default-method + [ empty-method ] with-standard ; + +M: standard-combination perform-combination + [ single-combination ] with-standard ; + +TUPLE: hook-combination var ; + +C: hook-combination + +PREDICATE: hook-generic < generic + "combination" word-prop hook-combination? ; + +: with-hook ( combination quot -- quot' ) + 0 (dispatch#) [ + dip var>> [ get ] curry prepend + ] with-variable ; inline + +M: hook-combination make-default-method + [ error-method ] with-hook ; + +M: hook-combination perform-combination + [ single-combination ] with-hook ; + +GENERIC: dispatch# ( word -- n ) + +M: word dispatch# "combination" word-prop dispatch# ; + +M: standard-combination dispatch# #>> ; + +M: hook-combination dispatch# drop 0 ; + +M: simple-generic definer drop \ GENERIC: f ; + +M: standard-generic definer drop \ GENERIC# f ; + +M: hook-generic definer drop \ HOOK: f ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 4ed883dad5..65b66e9538 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -41,23 +41,13 @@ ERROR: no-method object generic ; : class-predicates ( assoc -- assoc ) [ >r "predicate" word-prop picker prepend 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 ; +: simplify-alist ( class assoc -- default assoc' ) + { + { [ dup empty? ] [ 2drop [ "Unreachable" throw ] { } ] } + { [ dup length 1 = ] [ nip first second { } ] } + { [ 2dup second first class< ] [ 1 tail-slice simplify-alist ] } + { [ t ] [ nip [ first second ] [ 1 tail-slice ] bi ] } + } cond ; : default-method ( word -- pair ) "default-method" word-prop diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 5ca9b1b2e7..61412ccf9f 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -3,14 +3,23 @@ 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 ; 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: tuple-dispatch-engine-word inline? + "tuple-dispatch-generic" word-prop inline? ; + +M: word inline? + "inline" word-prop ; : local-recursive-state ( -- assoc ) recursive-state get dup keys diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 67b8616c61..7d18aaa489 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -120,7 +120,7 @@ M: object xyz ; [ [ no-cond ] 1 [ 1array dup quotation? [ >quotation ] unless ] times - ] \ type inlined? + ] \ quotation? inlined? ] unit-test [ f ] [ [ length ] \ slot inlined? ] unit-test diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 79e41c8ae4..3cc78831a3 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -383,9 +383,6 @@ set-primitive-effect \ millis { } { integer } set-primitive-effect \ millis make-flushable -\ type { object } { fixnum } set-primitive-effect -\ type make-foldable - \ tag { object } { fixnum } set-primitive-effect \ tag make-foldable diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index b1120de8e6..2df5e69998 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -413,12 +413,6 @@ HELP: clone { $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" } "." } ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index ab42a1b903..eed5b22e5f 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel.private ; +USING: kernel.private slots.private ; IN: kernel ! Stack stuff @@ -99,14 +99,14 @@ DEFER: if ! Appliers : bi@ ( x y quot -- ) - tuck 2slip call ; inline + dup bi* ; inline : tri@ ( x y z quot -- ) - tuck >r bi@ r> call ; inline + dup dup tri* ; inline ! Double appliers : 2bi@ ( w x y z quot -- ) - dup -roll 3slip call ; inline + dup 2bi* ; inline : while ( pred body tail -- ) >r >r dup slip r> r> roll @@ -194,6 +194,8 @@ GENERIC: construct-boa ( ... class -- tuple ) class } { $subsection type-number } diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 108c715ef0..a4782078ee 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -87,29 +87,6 @@ sequences.private combinators ; { { @ @ } [ 2drop t ] } } define-identities -! type applied to an object of a known type can be folded -: known-type? ( node -- ? ) - node-class-first class-types length 1 number= ; - -: fold-known-type ( node -- node ) - dup node-class-first class-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 From f96a43c42daaa07a4c63940f77552733e3309950 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 00:45:30 -0500 Subject: [PATCH 386/886] Getting ready to drop in new dispatch code --- core/classes/algebra/algebra-tests.factor | 2 +- core/generic/standard/engines/tag/tag.factor | 2 +- core/generic/standard/new/new.factor | 6 ++++++ core/generic/standard/standard.factor | 2 +- 4 files changed, 9 insertions(+), 3 deletions(-) diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index cdf817e31d..dc65b09579 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -96,7 +96,7 @@ UNION: z1 b1 c1 ; [ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test -[ f ] [ growable hi-tag classes-intersect? ] unit-test +[ f ] [ growable \ hi-tag classes-intersect? ] unit-test [ t ] [ growable tuple sequence class-and class< diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index fd40af0e50..1bcd007d0d 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/core/generic/standard/engines/tag/tag.factor @@ -13,7 +13,7 @@ TUPLE: hi-tag-dispatch-engine methods ; C: hi-tag-dispatch-engine : convert-hi-tag-methods ( assoc -- assoc' ) - hi-tag \ convert-methods ; + \ hi-tag \ convert-methods ; : direct-dispatch-quot ( alist n -- quot ) default get diff --git a/core/generic/standard/new/new.factor b/core/generic/standard/new/new.factor index b2371cc4e5..00c33e38fd 100644 --- a/core/generic/standard/new/new.factor +++ b/core/generic/standard/new/new.factor @@ -100,6 +100,9 @@ PREDICATE: simple-generic < standard-generic : with-standard ( combination quot -- quot' ) >r #>> (dispatch#) r> with-variable ; +M: standard-generic mangle-method + drop ; + M: standard-combination make-default-method [ empty-method ] with-standard ; @@ -118,6 +121,9 @@ PREDICATE: hook-generic < generic dip var>> [ get ] curry prepend ] with-variable ; inline +M: hook-generic mangle-method + drop [ drop ] prepend ; + M: hook-combination make-default-method [ error-method ] with-hook ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 65b66e9538..b77c0ed9e5 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -77,7 +77,7 @@ ERROR: no-method object generic ; [ small-generic ] picker class-hash-dispatch-quot ; : vtable-class ( n -- class ) - bootstrap-type>class [ hi-tag bootstrap-word ] unless* ; + bootstrap-type>class [ \ hi-tag bootstrap-word ] unless* ; : group-methods ( assoc -- vtable ) #! Input is a predicate -> method association. From 7a596ce004972a0e8ddea4cc959ce3185f7feaa6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 02:44:10 -0500 Subject: [PATCH 387/886] Debugging inheritancE --- core/assocs/assocs.factor | 26 ++- core/classes/algebra/algebra-tests.factor | 2 +- core/classes/classes.factor | 40 ++-- core/classes/predicate/predicate.factor | 11 +- core/classes/tuple/tuple-tests.factor | 4 +- core/classes/tuple/tuple.factor | 34 ++- core/classes/union/union.factor | 28 +-- core/cpu/ppc/intrinsics/intrinsics.factor | 49 ---- core/generic/generic-docs.factor | 9 - core/generic/standard/engines/tag/tag.factor | 5 +- core/generic/standard/new/new.factor | 145 ------------ ...new-tests.factor => standard-tests.factor} | 8 +- core/generic/standard/standard.factor | 219 +++++++----------- core/mirrors/mirrors.factor | 21 -- .../specializers/specializers.factor | 3 +- 15 files changed, 177 insertions(+), 427 deletions(-) delete mode 100644 core/generic/standard/new/new.factor rename core/generic/standard/{new/new-tests.factor => standard-tests.factor} (94%) mode change 100755 => 100644 core/generic/standard/standard.factor diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index b911faf672..6b6bd3d51a 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -1,6 +1,7 @@ -! 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 @@ -189,3 +190,24 @@ M: f clear-assoc drop ; M: f assoc-like drop dup assoc-empty? [ drop f ] when ; INSTANCE: sequence assoc + +TUPLE: enum seq ; + +C: 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 2array flip ; + +M: enum assoc-size seq>> length ; + +M: enum clear-assoc seq>> delete-all ; + +INSTANCE: enum assoc diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index dc65b09579..32664dc823 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -4,7 +4,7 @@ kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.algebra classes.private classes.union classes.mixin classes.predicate vectors definitions source-files compiler.units growable -random inference effects ; +random inference effects kernel.private ; : class= [ class< ] 2keep swap class< and ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index d91b1bb217..914e070e03 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -83,7 +83,7 @@ M: word reset-class drop ; : update-map- ( class -- ) dup class-uses update-map get remove-vertex ; -: define-class-props ( superclass members metaclass -- assoc ) +: make-class-props ( superclass members metaclass -- assoc ) [ [ dup [ bootstrap-word ] when "superclass" set ] [ [ bootstrap-word ] map "members" set ] @@ -92,12 +92,16 @@ M: word reset-class drop ; ] 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> 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 ; PRIVATE> @@ -105,24 +109,22 @@ GENERIC: update-class ( class -- ) M: class update-class drop ; -: update-classes ( assoc -- ) - [ drop update-class ] assoc-each ; - GENERIC: update-methods ( assoc -- ) +: update-classes ( class -- ) + class-usages + [ [ drop update-class ] assoc-each ] + [ update-methods ] + bi ; + : define-class ( word superclass members metaclass -- ) #! If it was already a class, update methods after. reset-caches - define-class-props + make-class-props [ drop update-map- ] - [ (define-class) ] [ - drop - [ update-map+ ] [ - class-usages - [ update-classes ] - [ update-methods ] bi - ] bi - ] 2tri ; + [ (define-class) ] + [ drop update-map+ ] + 2tri ; GENERIC: class ( object -- class ) diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index b2a5a03bb4..0f98f1f5c4 100755 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -14,9 +14,14 @@ PREDICATE: predicate-class < class ] [ ] make ; : define-predicate-class ( class superclass definition -- ) - >r dupd f predicate-class define-class - r> dupd "predicate-definition" set-word-prop - dup predicate-quot define-predicate ; + [ 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 { diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index db0e25f091..228de8aabf 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -62,13 +62,13 @@ C: point [ 200 ] [ "p" get y>> ] unit-test [ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test -"p" get 300 ">>z" "accessors" lookup execute drop +[ ] [ "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 +[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test [ 3 ] [ "p" get tuple-size ] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 3cacef25a1..bbc221b85d 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -161,25 +161,23 @@ PRIVATE> : update-tuples-after ( class -- ) outdated-tuples get [ all-slot-names ] cache drop ; -: subclasses ( class -- classes ) - class-usages keys [ tuple-class? ] subset ; - -: each-subclass ( class quot -- ) - >r subclasses r> each ; inline - -: define-tuple-shape ( class -- ) - [ define-tuple-slots ] +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 - [ define-tuple-shape ] each-subclass - ] 3tri ; + [ 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 -- ) [ @@ -214,6 +212,9 @@ M: tuple-class define-tuple-class [ define-tuple-class ] [ 2drop ] 3bi dup [ construct-boa throw ] curry define ; +M: tuple-class reset-class + { "metaclass" "superclass" "slots" "layout" } reset-props ; + M: tuple clone (clone) dup delegate clone over set-delegate ; @@ -227,12 +228,6 @@ M: tuple hashcode* ] 2curry reduce ] recursive-hashcode ; -M: tuple-class reset-class - { "metaclass" "superclass" "slots" "layout" } reset-props ; - -M: object get-slots ( obj slots -- ... ) - [ execute ] with each ; - M: object construct-empty ( class -- tuple ) tuple-layout ; @@ -240,6 +235,9 @@ M: object construct-boa ( ... class -- tuple ) tuple-layout ; ! Deprecated +M: object get-slots ( obj slots -- ... ) + [ execute ] with each ; + M: object set-slots ( ... obj slots -- ) get-slots ; diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index e9b98770dc..9079974a60 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -1,33 +1,21 @@ ! 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: 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 ] prepend 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 -- ) @@ -36,7 +24,9 @@ PREDICATE: union-class < class M: union-class update-class define-union-predicate ; : define-union-class ( class members -- ) - f swap union-class define-class ; + [ f swap union-class define-class ] + [ drop update-classes ] + 2bi ; M: union-class reset-class { "metaclass" "members" } reset-props ; diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 07698eaa92..d092473960 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -402,55 +402,6 @@ IN: cpu.ppc.intrinsics { +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 ; diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 56de801e7a..100475455a 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -63,15 +63,6 @@ ARTICLE: "method-combination" "Custom method combination" "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: "generic" "Generic words and methods" diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index 1bcd007d0d..3dd8b83579 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/core/generic/standard/engines/tag/tag.factor @@ -1,7 +1,6 @@ USING: classes.private generic.standard.engines namespaces -arrays mirrors assocs sequences.private quotations -kernel.private layouts math slots.private math.private -kernel accessors ; +arrays assocs sequences.private quotations kernel.private +layouts math slots.private math.private kernel accessors ; IN: generic.standard.engines.tag TUPLE: lo-tag-dispatch-engine methods ; diff --git a/core/generic/standard/new/new.factor b/core/generic/standard/new/new.factor deleted file mode 100644 index 00c33e38fd..0000000000 --- a/core/generic/standard/new/new.factor +++ /dev/null @@ -1,145 +0,0 @@ -! Copyright (C) 2005, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs kernel kernel.private slots.private math -namespaces sequences vectors words quotations definitions -hashtables layouts combinators sequences.private generic -classes classes.algebra classes.private generic.standard.engines -generic.standard.engines.tag generic.standard.engines.predicate -generic.standard.engines.tuple accessors ; -IN: generic.standard.new - -: unpickers - { - [ nip ] - [ >r nip r> swap ] - [ >r >r nip r> r> -rot ] - } ; inline - -: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ; - -ERROR: no-method object generic ; - -: error-method ( word -- quot ) - picker swap [ no-method ] curry append ; - -: empty-method ( word -- quot ) - [ - picker % [ delegate dup ] % - unpicker over suffix , - error-method \ drop prefix , \ if , - ] [ ] make ; - -: default-method ( word -- pair ) - "default-method" word-prop - object bootstrap-word swap 2array ; - -: push-method ( method specializer atomic assoc -- ) - [ - [ H{ } clone ] 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 ; - -: ( assoc -- engine ) - flatten-methods - convert-tuple-methods - convert-hi-tag-methods - ; - -: find-default ( methods -- quot ) - #! Side-effects methods. - object swap delete-at* [ - drop generic get "default-method" word-prop - ] unless 1quotation ; - -GENERIC: mangle-method ( method generic -- quot ) - -: single-combination ( words -- quot ) - [ - object bootstrap-word assumed set - [ generic set ] - [ - "methods" word-prop - [ generic get mangle-method ] assoc-map - [ find-default default set ] - [ - generic get "inline" word-prop [ - - ] [ - - ] if - ] bi - engine>quot - ] bi - ] with-scope ; - -TUPLE: standard-combination # ; - -C: standard-combination - -PREDICATE: standard-generic < generic - "combination" word-prop standard-combination? ; - -PREDICATE: simple-generic < standard-generic - "combination" word-prop #>> zero? ; - -: define-simple-generic ( word -- ) - T{ standard-combination f 0 } define-generic ; - -: with-standard ( combination quot -- quot' ) - >r #>> (dispatch#) r> with-variable ; - -M: standard-generic mangle-method - drop ; - -M: standard-combination make-default-method - [ empty-method ] with-standard ; - -M: standard-combination perform-combination - [ single-combination ] with-standard ; - -TUPLE: hook-combination var ; - -C: hook-combination - -PREDICATE: hook-generic < generic - "combination" word-prop hook-combination? ; - -: with-hook ( combination quot -- quot' ) - 0 (dispatch#) [ - dip var>> [ get ] curry prepend - ] with-variable ; inline - -M: hook-generic mangle-method - drop [ drop ] prepend ; - -M: hook-combination make-default-method - [ error-method ] with-hook ; - -M: hook-combination perform-combination - [ single-combination ] with-hook ; - -GENERIC: dispatch# ( word -- n ) - -M: word dispatch# "combination" word-prop dispatch# ; - -M: standard-combination dispatch# #>> ; - -M: hook-combination dispatch# drop 0 ; - -M: simple-generic definer drop \ GENERIC: f ; - -M: standard-generic definer drop \ GENERIC# f ; - -M: hook-generic definer drop \ HOOK: f ; diff --git a/core/generic/standard/new/new-tests.factor b/core/generic/standard/standard-tests.factor similarity index 94% rename from core/generic/standard/new/new-tests.factor rename to core/generic/standard/standard-tests.factor index d372926f43..fbca22471c 100644 --- a/core/generic/standard/new/new-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -1,10 +1,8 @@ -IN: generic.standard.new.tests +IN: generic.standard.tests USING: tools.test math math.functions math.constants -generic.standard.new strings sequences arrays kernel accessors +generic.standard strings sequences arrays kernel accessors words float-arrays byte-arrays bit-arrays parser ; -<< : GENERIC: CREATE-GENERIC define-simple-generic ; parsing >> - GENERIC: lo-tag-test M: integer lo-tag-test 3 + ; @@ -24,7 +22,7 @@ GENERIC: hi-tag-test M: string hi-tag-test ", in bed" append ; -M: number hi-tag-test 3 + ; +M: integer hi-tag-test 3 + ; M: array hi-tag-test [ hi-tag-test ] map ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor old mode 100755 new mode 100644 index b77c0ed9e5..1de41f24ed --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -3,32 +3,23 @@ USING: arrays assocs kernel kernel.private slots.private math namespaces sequences vectors words quotations definitions hashtables layouts combinators sequences.private generic -classes classes.algebra 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 - -SYMBOL: (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 ; ERROR: no-method object generic ; -: error-method ( word -- quot ) +: error-method ( word -- quot ) picker swap [ no-method ] curry append ; : empty-method ( word -- quot ) @@ -38,144 +29,112 @@ ERROR: no-method object generic ; error-method \ drop prefix , \ if , ] [ ] make ; -: class-predicates ( assoc -- assoc ) - [ >r "predicate" word-prop picker prepend r> ] assoc-map ; - -: simplify-alist ( class assoc -- default assoc' ) - { - { [ dup empty? ] [ 2drop [ "Unreachable" throw ] { } ] } - { [ dup length 1 = ] [ nip first second { } ] } - { [ 2dup second first class< ] [ 1 tail-slice simplify-alist ] } - { [ t ] [ nip [ first second ] [ 1 tail-slice ] bi ] } - } cond ; - : 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 -- ) [ - picker % - \ tag , - group-methods build-type-vtable , - \ dispatch , - ] [ ] make ; + [ H{ } clone ] unless* + [ methods>> set-at ] keep + ] change-at ; -: flatten-method ( class body -- ) - over members pick object bootstrap-word eq? not and [ - >r members r> [ flatten-method ] curry each - ] [ - swap set - ] if ; +: flatten-method ( class method assoc -- ) + >r >r dup flatten-class keys swap r> r> [ + >r spin r> push-method + ] 3curry each ; -: flatten-methods ( methods -- newmethods ) - [ [ flatten-method ] assoc-each ] V{ } make-assoc ; +: flatten-methods ( assoc -- assoc' ) + H{ } clone [ + [ + flatten-method + ] curry assoc-each + ] keep ; -: dispatched-types ( methods -- seq ) - keys object bootstrap-word swap remove prune ; +: ( assoc -- engine ) + flatten-methods + convert-tuple-methods + convert-hi-tag-methods + ; -: single-combination ( methods -- quot ) - dup length 4 <= [ - small-generic - ] [ - flatten-methods - dup dispatched-types [ number class< ] all? - [ tag-generic ] [ big-generic ] if - ] if ; +: find-default ( methods -- quot ) + #! Side-effects methods. + object swap delete-at* [ + drop generic get "default-method" word-prop 1quotation + ] unless ; -: standard-methods ( word -- alist ) - dup methods swap default-method prefix - [ 1quotation ] assoc-map ; +GENERIC: mangle-method ( method generic -- quot ) -M: standard-combination make-default-method - standard-combination-# (dispatch#) - [ empty-method ] with-variable ; - -M: standard-combination perform-combination - standard-combination-# (dispatch#) [ - [ standard-methods ] keep "inline" word-prop - [ small-generic ] [ single-combination ] if - ] with-variable ; - -TUPLE: hook-combination var ; - -C: hook-combination - -: with-hook ( combination quot -- quot' ) - 0 (dispatch#) [ - swap slip - hook-combination-var [ get ] curry - prepend - ] with-variable ; inline - -M: hook-combination make-default-method - [ error-method ] with-hook ; - -M: hook-combination perform-combination +: single-combination ( words -- quot ) [ - standard-methods - [ [ drop ] prepend ] assoc-map - single-combination - ] with-hook ; + object bootstrap-word assumed set + [ generic set ] + [ + "methods" word-prop + [ generic get mangle-method ] assoc-map + [ find-default default set ] + [ + generic get "inline" word-prop [ + + ] [ + + ] if + ] bi + engine>quot + ] bi + ] with-scope ; -: define-simple-generic ( word -- ) - T{ standard-combination f 0 } define-generic ; +TUPLE: standard-combination # ; + +C: standard-combination PREDICATE: standard-generic < generic "combination" word-prop standard-combination? ; PREDICATE: simple-generic < standard-generic - "combination" word-prop standard-combination-# zero? ; + "combination" word-prop #>> zero? ; + +: define-simple-generic ( word -- ) + T{ standard-combination f 0 } define-generic ; + +: with-standard ( combination quot -- quot' ) + >r #>> (dispatch#) r> with-variable ; + +M: standard-generic mangle-method + drop 1quotation ; + +M: standard-combination make-default-method + [ empty-method ] with-standard ; + +M: standard-combination perform-combination + [ single-combination ] with-standard ; + +TUPLE: hook-combination var ; + +C: hook-combination PREDICATE: hook-generic < generic "combination" word-prop hook-combination? ; +: with-hook ( combination quot -- quot' ) + 0 (dispatch#) [ + dip var>> [ get ] curry prepend + ] with-variable ; inline + +M: hook-generic mangle-method + drop 1quotation [ drop ] prepend ; + +M: hook-combination make-default-method + [ error-method ] with-hook ; + +M: hook-combination perform-combination + [ single-combination ] with-hook ; + GENERIC: dispatch# ( word -- n ) M: word dispatch# "combination" word-prop dispatch# ; -M: standard-combination dispatch# standard-combination-# ; +M: standard-combination dispatch# #>> ; M: hook-combination dispatch# drop 0 ; diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index fde8728858..a13e1331fa 100755 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -48,27 +48,6 @@ M: mirror assoc-size mirror-slots length ; INSTANCE: mirror assoc -TUPLE: enum seq ; - -C: 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 diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index cbdb1b9ec4..d115d0a1c6 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic hashtables kernel kernel.private math namespaces sequences vectors words strings layouts combinators -sequences.private classes generic.standard assocs ; +sequences.private classes generic.standard +generic.standard.engines assocs ; IN: optimizer.specializers : (make-specializer) ( class picker -- quot ) From 11feb563ebdb1ca453ac1d96e8391a9b07478bf1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 2 Apr 2008 13:11:55 -0500 Subject: [PATCH 388/886] move singletons to core --- core/bootstrap/syntax.factor | 1 + {extra => core}/classes/singleton/authors.txt | 0 {extra => core}/classes/singleton/singleton-docs.factor | 0 {extra => core}/classes/singleton/singleton-tests.factor | 2 +- {extra => core}/classes/singleton/singleton.factor | 3 --- core/syntax/syntax.factor | 6 +++++- 6 files changed, 7 insertions(+), 5 deletions(-) rename {extra => core}/classes/singleton/authors.txt (100%) rename {extra => core}/classes/singleton/singleton-docs.factor (100%) rename {extra => core}/classes/singleton/singleton-tests.factor (75%) rename {extra => core}/classes/singleton/singleton.factor (92%) diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index e7e90d8dd0..e5a439c32b 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -43,6 +43,7 @@ IN: bootstrap.syntax "PRIMITIVE:" "PRIVATE>" "SBUF\"" + "SINLETON:" "SYMBOL:" "TUPLE:" "T{" diff --git a/extra/classes/singleton/authors.txt b/core/classes/singleton/authors.txt similarity index 100% rename from extra/classes/singleton/authors.txt rename to core/classes/singleton/authors.txt diff --git a/extra/classes/singleton/singleton-docs.factor b/core/classes/singleton/singleton-docs.factor similarity index 100% rename from extra/classes/singleton/singleton-docs.factor rename to core/classes/singleton/singleton-docs.factor diff --git a/extra/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor similarity index 75% rename from extra/classes/singleton/singleton-tests.factor rename to core/classes/singleton/singleton-tests.factor index 586724ee3b..11a2a2d166 100644 --- a/extra/classes/singleton/singleton-tests.factor +++ b/core/classes/singleton/singleton-tests.factor @@ -9,4 +9,4 @@ GENERIC: zammo ( obj -- ) [ "yes!" ] [ bzzt zammo ] unit-test [ ] [ SINGLETON: omg ] unit-test [ t ] [ omg singleton? ] unit-test -[ "USING: classes.singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test +[ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test diff --git a/extra/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor similarity index 92% rename from extra/classes/singleton/singleton.factor rename to core/classes/singleton/singleton.factor index 61a519679c..13fd242dad 100755 --- a/extra/classes/singleton/singleton.factor +++ b/core/classes/singleton/singleton.factor @@ -15,8 +15,5 @@ PREDICATE: singleton < predicate-class \ singleton over [ eq? ] curry define-predicate-class ; -: SINGLETON: - scan define-singleton ; parsing - M: singleton see-class* ( class -- ) Date: Wed, 2 Apr 2008 13:13:56 -0500 Subject: [PATCH 389/886] fix unit test --- core/classes/singleton/singleton-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor index 11a2a2d166..92a9877477 100644 --- a/core/classes/singleton/singleton-tests.factor +++ b/core/classes/singleton/singleton-tests.factor @@ -4,7 +4,7 @@ IN: classes.singleton.tests [ ] [ SINGLETON: bzzt ] unit-test [ t ] [ bzzt bzzt? ] unit-test [ t ] [ bzzt bzzt eq? ] unit-test -GENERIC: zammo ( obj -- ) +GENERIC: zammo ( obj -- str ) [ ] [ M: bzzt zammo drop "yes!" ; ] unit-test [ "yes!" ] [ bzzt zammo ] unit-test [ ] [ SINGLETON: omg ] unit-test From c89ee5bfccfb8d6e19906841b3dd5fc06917b74c Mon Sep 17 00:00:00 2001 From: erg Date: Wed, 2 Apr 2008 15:11:11 -0500 Subject: [PATCH 390/886] add textwrangler binding --- extra/editors/textwrangler/authors.txt | 1 + extra/editors/textwrangler/summary.txt | 1 + extra/editors/textwrangler/textwrangler.factor | 13 +++++++++++++ 3 files changed, 15 insertions(+) create mode 100644 extra/editors/textwrangler/authors.txt create mode 100644 extra/editors/textwrangler/summary.txt create mode 100644 extra/editors/textwrangler/textwrangler.factor diff --git a/extra/editors/textwrangler/authors.txt b/extra/editors/textwrangler/authors.txt new file mode 100644 index 0000000000..b4a113da41 --- /dev/null +++ b/extra/editors/textwrangler/authors.txt @@ -0,0 +1 @@ +Ben Schlingelhof diff --git a/extra/editors/textwrangler/summary.txt b/extra/editors/textwrangler/summary.txt new file mode 100644 index 0000000000..cf502f96e5 --- /dev/null +++ b/extra/editors/textwrangler/summary.txt @@ -0,0 +1 @@ +Textwrangler editor integration diff --git a/extra/editors/textwrangler/textwrangler.factor b/extra/editors/textwrangler/textwrangler.factor new file mode 100644 index 0000000000..e97dadcdcb --- /dev/null +++ b/extra/editors/textwrangler/textwrangler.factor @@ -0,0 +1,13 @@ +! 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 From 47b54b13072b91c4b3bdf2ecfb7673bd77aedaea Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 2 Apr 2008 15:41:29 -0500 Subject: [PATCH 391/886] add singletons to core --- core/bootstrap/syntax.factor | 2 +- core/classes/singleton/singleton-tests.factor | 2 +- core/classes/singleton/singleton.factor | 16 ++++------------ core/prettyprint/prettyprint.factor | 5 ++++- core/syntax/syntax.factor | 7 ++++--- 5 files changed, 14 insertions(+), 18 deletions(-) diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index e5a439c32b..fb5923382e 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -43,7 +43,7 @@ IN: bootstrap.syntax "PRIMITIVE:" "PRIVATE>" "SBUF\"" - "SINLETON:" + "SINGLETON:" "SYMBOL:" "TUPLE:" "T{" diff --git a/core/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor index 92a9877477..2ed51abb93 100644 --- a/core/classes/singleton/singleton-tests.factor +++ b/core/classes/singleton/singleton-tests.factor @@ -8,5 +8,5 @@ GENERIC: zammo ( obj -- str ) [ ] [ M: bzzt zammo drop "yes!" ; ] unit-test [ "yes!" ] [ bzzt zammo ] unit-test [ ] [ SINGLETON: omg ] unit-test -[ t ] [ omg singleton? ] unit-test +[ t ] [ omg singleton-class? ] unit-test [ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test diff --git a/core/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor index 13fd242dad..65d7422ed7 100755 --- a/core/classes/singleton/singleton.factor +++ b/core/classes/singleton/singleton.factor @@ -1,19 +1,11 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: classes.predicate kernel namespaces parser quotations -sequences words prettyprint prettyprint.backend prettyprint.sections -compiler.units classes ; +USING: classes.predicate kernel sequences words ; IN: classes.singleton -PREDICATE: singleton < predicate-class +PREDICATE: singleton-class < predicate-class [ "predicate-definition" word-prop ] [ [ eq? ] curry ] bi sequence= ; -: define-singleton ( token -- ) - create-class-in - dup save-location - \ singleton - over [ eq? ] curry define-predicate-class ; - -M: singleton see-class* ( class -- ) - block> ; +M: singleton-class see-class* ( class -- ) + \ SINGLETON: pprint-word pprint-word ; + M: tuple-class see-class* Date: Wed, 2 Apr 2008 16:32:10 -0500 Subject: [PATCH 392/886] t is now a singleton --- core/syntax/syntax.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 90bb1f0a6d..37df12e9a7 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -55,7 +55,7 @@ IN: bootstrap.syntax "BIN:" [ 2 parse-base ] define-syntax "f" [ f parsed ] define-syntax - "t" "syntax" lookup define-symbol + "t" "syntax" lookup define-singleton-class "CHAR:" [ scan { From 7ec68e0aa7fce17bee0ea28fde27c0224c48ed8c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 2 Apr 2008 16:32:34 -0500 Subject: [PATCH 393/886] singleton docs --- core/classes/classes-docs.factor | 1 + core/classes/singleton/singleton-docs.factor | 16 +++++++++++++++- 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 9573de8949..5cc815fc36 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -47,6 +47,7 @@ $nl "Other sorts of classes:" { $subsection "builtin-classes" } { $subsection "unions" } +{ $subsection "singletons" } { $subsection "mixins" } { $subsection "predicates" } "Classes can be inspected and operated upon:" diff --git a/core/classes/singleton/singleton-docs.factor b/core/classes/singleton/singleton-docs.factor index 95b5b6af18..8548f84a3a 100644 --- a/core/classes/singleton/singleton-docs.factor +++ b/core/classes/singleton/singleton-docs.factor @@ -1,6 +1,11 @@ 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. Methods may dispatch off of singleton classes." +{ $subsection POSTPONE: SINGLETON: } +{ $subsection define-singleton-class } ; + HELP: SINGLETON: { $syntax "SINGLETON: class" } { $values @@ -8,7 +13,16 @@ HELP: SINGLETON: } { $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!" } + { $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" } } { $see-also POSTPONE: PREDICATE: } ; + +HELP: define-singleton-class +{ $values { "word" "a new word" } } +{ $description + "Defines a newly created word to be a singleton class." } ; + +{ POSTPONE: SINGLETON: define-singleton-class } related-words + +ABOUT: "singletons" From d736a8660da45d0778d340f504f6c9cacc4cb6e2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 2 Apr 2008 16:32:58 -0500 Subject: [PATCH 394/886] cpu is now a singleton --- core/bootstrap/compiler/compiler.factor | 2 +- core/bootstrap/image/image.factor | 3 ++- core/system/system.factor | 32 +++++++++++++++++++++++-- 3 files changed, 33 insertions(+), 4 deletions(-) diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 7d4db3c473..ab09279a7b 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -14,7 +14,7 @@ IN: bootstrap.compiler "alien.remote-control" require ] unless -"cpu." cpu append require +"cpu." cpu word-name append require : enable-compiler ( -- ) [ optimized-recompile-hook ] recompile-hook set-global ; diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index fc963683b6..e2fa5833eb 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -12,7 +12,8 @@ io.encodings.binary ; IN: bootstrap.image : my-arch ( -- arch ) - cpu dup "ppc" = [ >r os "-" r> 3append ] when ; + cpu word-name + dup "ppc" = [ >r os "-" r> 3append ] when ; : boot-image-name ( arch -- string ) "boot." swap ".image" 3append ; diff --git a/core/system/system.factor b/core/system/system.factor index 87bbcfdc3f..5a0faeece9 100755 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -2,12 +2,40 @@ ! 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 +! : cpu ( -- cpu ) 8 getenv ; foldable : os ( -- os ) 9 getenv ; foldable +SINGLETON: x86.32 +SINGLETON: x86.64 +SINGLETON: arm +SINGLETON: ppc + +: cpu ( -- class ) \ cpu get ; + +! SINGLETON: winnt +! SINGLETON: wince + +! MIXIN: windows +! INSTANCE: winnt windows +! INSTANCE: wince windows + +! SINGLETON: freebsd +! SINGLETON: netbsd +! SINGLETON: openbsd +! SINGLETON: solaris +! SINGLETON: macosx +! SINGLETON: linux + +! : os ( -- class ) \ os get ; + +[ + 8 getenv "system" lookup \ cpu set-global + ! 9 getenv "system" lookup \ os set-global +] "system" add-init-hook + : image ( -- path ) 13 getenv ; : vm ( -- path ) 14 getenv ; From 7cb3fdcfec85f100a33f0a81b763a54aa75d19c1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 2 Apr 2008 17:07:38 -0500 Subject: [PATCH 395/886] compiler backend now dispatches on the os --- core/cpu/architecture/architecture.factor | 94 +++++++++---------- core/cpu/ppc/allot/allot.factor | 4 +- core/cpu/ppc/architecture/architecture.factor | 86 +++++++++-------- core/cpu/ppc/ppc.factor | 2 - core/cpu/x86/32/32.factor | 59 ++++++------ core/cpu/x86/64/64.factor | 63 ++++++------- core/cpu/x86/allot/allot.factor | 4 +- core/cpu/x86/architecture/architecture.factor | 72 +++++++------- core/system/system.factor | 22 ++++- 9 files changed, 200 insertions(+), 206 deletions(-) diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 8d1e1f281f..4670cf86d2 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -5,8 +5,6 @@ namespaces sequences layouts system hashtables classes alien byte-arrays bit-arrays float-arrays combinators words ; IN: cpu.architecture -SYMBOL: compiler-backend - ! A pseudo-register class for parameters spilled on the stack TUPLE: stack-params ; @@ -26,122 +24,122 @@ GENERIC: vregs ( register-class -- regs ) ! 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-t 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 ; @@ -179,15 +177,15 @@ PREDICATE: inline-array < integer 32 < ; ] 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 -- ) : operand ( var -- op ) get v>operand ; inline diff --git a/core/cpu/ppc/allot/allot.factor b/core/cpu/ppc/allot/allot.factor index 6c37fce4f1..34ea82dc4e 100755 --- a/core/cpu/ppc/allot/allot.factor +++ b/core/cpu/ppc/allot/allot.factor @@ -32,7 +32,7 @@ IN: cpu.ppc.allot 12 11 float tag-number ORI f fresh-object ; -M: ppc-backend %box-float ( dst src -- ) +M: ppc %box-float ( dst src -- ) [ v>operand ] bi@ %allot-float 12 MR ; : %allot-bignum ( #digits -- ) @@ -78,7 +78,7 @@ M: ppc-backend %box-float ( dst src -- ) "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 diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 903ac32df9..8055e4ff6e 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -7,8 +7,6 @@ layouts classes words.private alien combinators compiler.constants ; IN: cpu.ppc.architecture -TUPLE: ppc-backend ; - ! PowerPC register assignments ! r3-r10, r16-r31: integer vregs ! f0-f13: float vregs @@ -44,7 +42,7 @@ TUPLE: ppc-backend ; : 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 ; @@ -73,14 +71,14 @@ M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ; M: immediate load-literal [ 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 @@ -88,7 +86,7 @@ M: ppc-backend %prologue ( n -- ) 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, @@ -104,14 +102,14 @@ M: ppc-backend %epilogue ( n -- ) : %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 -- ) +M: ppc %jump-t ( label -- ) 0 "flag" operand f v>operand CMPI BNE ; -M: ppc-backend %dispatch ( -- ) +M: ppc %dispatch ( -- ) [ %epilogue-later 0 11 LOAD32 rc-absolute-ppc-2/2 rel-here @@ -124,25 +122,25 @@ M: ppc-backend %dispatch ( -- ) { +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 -- ) +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 ; @@ -166,19 +164,19 @@ M: stack-params %save-param-reg ( stack reg reg-class -- ) 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 @@ -188,7 +186,7 @@ M: ppc-backend %unbox-long-long ( n func -- ) 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 @@ -197,7 +195,7 @@ M: ppc-backend %unbox-large-struct ( n size -- ) ! 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. @@ -205,7 +203,7 @@ M: ppc-backend %box ( n reg-class func -- ) 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 @@ -215,12 +213,12 @@ M: ppc-backend %box-long-long ( n func -- ) : 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 @@ -230,7 +228,7 @@ M: ppc-backend %box-large-struct ( n size -- ) ! 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. @@ -240,20 +238,20 @@ M: ppc-backend %prepare-alien-invoke 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 @@ -264,7 +262,7 @@ M: ppc-backend %callback-value ( ctype -- ) ! 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 ; @@ -272,34 +270,34 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ; : %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 ; -M: ppc-backend fp-shadows-int? ( -- ? ) macosx? ; +M: ppc fp-shadows-int? ( -- ? ) 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 -- ) +M: ppc %unbox-byte-array ( dst src -- ) [ v>operand ] bi@ byte-array-offset ADDI ; -M: ppc-backend %unbox-alien ( dst src -- ) +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 diff --git a/core/cpu/ppc/ppc.factor b/core/cpu/ppc/ppc.factor index 75de49acda..da17da9185 100755 --- a/core/cpu/ppc/ppc.factor +++ b/core/cpu/ppc/ppc.factor @@ -12,8 +12,6 @@ namespaces alien.c-types kernel system combinators ; ] } } cond -T{ ppc-backend } compiler-backend set-global - macosx? [ 4 "double" c-type set-c-type-align ] when diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index f4af421cdd..3ebee73cbf 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -8,23 +8,20 @@ alien.compiler combinators command-line compiler compiler.units io vocabs.loader accessors ; IN: cpu.x86.32 -PREDICATE: x86-32-backend < x86-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 xt-reg ECX ; +M: x86.32 stack-save-reg EDX ; 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. @@ -61,20 +58,20 @@ M: float-regs store-return-reg load/store-float-return FSTP ; ! 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 ; @@ -87,7 +84,7 @@ M: x86-32-backend %prepare-unbox ( -- ) 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 @@ -96,7 +93,7 @@ M: x86-32-backend %unbox ( n reg-class func -- ) ! 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 [ @@ -104,7 +101,7 @@ M: x86-32-backend %unbox-long-long ( n func -- ) 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 @@ -115,7 +112,7 @@ M: x86-32-backend %unbox-struct-2 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 @@ -147,7 +144,7 @@ M: x86-32-backend %unbox-large-struct ( n size -- ) 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 ; @@ -165,12 +162,12 @@ M: x86-32-backend %box ( n reg-class func -- ) 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 @@ -183,13 +180,13 @@ M: x86-32-backend %box-large-struct ( n size -- ) "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 @@ -198,7 +195,7 @@ M: x86-32-backend %unbox-struct-1 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 @@ -207,21 +204,21 @@ M: x86-32-backend %box-small-struct ( size -- ) "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 @@ -236,7 +233,7 @@ M: x86-32-backend %callback-value ( ctype -- ) ! 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. @@ -254,7 +251,7 @@ M: x86-32-backend %cleanup ( alien-node -- ) } } cond ; -M: x86-32-backend %unwind ( n -- ) %epilogue-later RET ; +M: x86.32 %unwind ( n -- ) %epilogue-later RET ; windows? [ cell "longlong" c-type set-c-type-align @@ -265,8 +262,6 @@ windows? [ 4 "double" c-type set-c-type-align ] unless -T{ x86-backend f 4 } compiler-backend set-global - : sse2? "Intrinsic" throw ; \ sse2? [ diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index c2af60e983..d3ccffe00e 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -8,14 +8,11 @@ layouts alien alien.accessors alien.compiler alien.structs slots splitting assocs ; IN: cpu.x86.64 -PREDICATE: amd64-backend < x86-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 xt-reg RCX ; +M: x86.64 stack-save-reg RSI ; M: temp-reg v>operand drop RBX ; @@ -34,18 +31,18 @@ M: float-regs vregs 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 @@ -56,27 +53,27 @@ 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 -- ) +M: x86.64 %unbox-long-long ( n func -- ) T{ 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 @@ -84,7 +81,7 @@ M: amd64-backend %unbox-struct-2 ( -- ) ! 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 @@ -97,7 +94,7 @@ M: amd64-backend %unbox-large-struct ( n size -- ) 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 ] [ @@ -105,19 +102,19 @@ M: amd64-backend %box ( n reg-class func -- ) ] if* f %alien-invoke ; -M: amd64-backend %box-long-long ( n func -- ) +M: x86.64 %box-long-long ( n func -- ) T{ 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 @@ -125,27 +122,27 @@ M: amd64-backend %box-large-struct ( n size -- ) ! 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 @@ -157,9 +154,9 @@ M: amd64-backend %callback-value ( ctype -- ) ! 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 @@ -171,8 +168,6 @@ 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 >> diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor index 5519a9a8d5..f236cdcfa6 100755 --- a/core/cpu/x86/allot/allot.factor +++ b/core/cpu/x86/allot/allot.factor @@ -46,7 +46,7 @@ IN: cpu.x86.allot 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 [ @@ -86,7 +86,7 @@ M: x86-backend %box-float ( dst src -- ) "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 diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index 31fa4c8e4b..76c4f1691a 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -6,13 +6,11 @@ memory namespaces sequences words generator generator.registers 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: xt-reg cpu +HOOK: stack-save-reg cpu : stack@ stack-reg swap [+] ; @@ -33,34 +31,34 @@ GENERIC: push-return-reg ( reg-class -- ) GENERIC: load-return-reg ( stack@ reg-class -- ) GENERIC: store-return-reg ( stack@ reg-class -- ) -HOOK: address-operand compiler-backend ( address -- operand ) +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 ( -- ) +M: x86 %save-word-xt ( -- ) xt-reg 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 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. @@ -70,11 +68,11 @@ M: x86-backend %prepare-alien-invoke 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 -- ) +M: x86 %jump-t ( label -- ) "flag" operand f v>operand CMP JNE ; : code-alignment ( -- n ) @@ -83,7 +81,7 @@ M: x86-backend %jump-t ( label -- ) : align-code ( n -- ) 0 % ; -M: x86-backend %dispatch ( -- ) +M: x86 %dispatch ( -- ) [ %epilogue-later ! Load jump table base. We use a temporary register @@ -105,27 +103,27 @@ M: x86-backend %dispatch ( -- ) { +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 -- ) +M: x86 %unbox-float ( dst src -- ) [ v>operand ] bi@ float-offset [+] MOVSD ; -M: x86-backend %peek [ v>operand ] bi@ 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 ; @@ -143,34 +141,34 @@ M: x86-backend small-enough? ( n -- ? ) \ 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" "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 -- ) +M: x86 %unbox-byte-array ( dst src -- ) [ v>operand ] bi@ byte-array-offset [+] LEA ; -M: x86-backend %unbox-alien ( dst src -- ) +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 diff --git a/core/system/system.factor b/core/system/system.factor index 5a0faeece9..459af28537 100755 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -13,14 +13,14 @@ SINGLETON: x86.64 SINGLETON: arm SINGLETON: ppc +UNION: x86 x86.32 x86.64 ; + : cpu ( -- class ) \ cpu get ; ! SINGLETON: winnt ! SINGLETON: wince -! MIXIN: windows -! INSTANCE: winnt windows -! INSTANCE: wince windows +! UNION: windows winnt wince ; ! SINGLETON: freebsd ! SINGLETON: netbsd @@ -29,11 +29,23 @@ SINGLETON: ppc ! SINGLETON: macosx ! SINGLETON: linux +cpu ( str -- class ) + H{ + { "x86.32" x86.32 } + { "x86.64" x86.64 } + { "arm" arm } + { "ppc" ppc } + } at ; + +PRIVATE> + ! : os ( -- class ) \ os get ; [ - 8 getenv "system" lookup \ cpu set-global - ! 9 getenv "system" lookup \ os set-global + 8 getenv string>cpu \ cpu set-global + ! 9 getenv string>os \ os set-global ] "system" add-init-hook : image ( -- path ) 13 getenv ; From 393f77715cafa447f6e9499ba61cd319c2620e28 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 2 Apr 2008 18:25:33 -0500 Subject: [PATCH 396/886] update everything to use os singletons --- core/alien/alien-docs.factor | 4 +- core/alien/alien.factor | 2 +- core/bootstrap/image/image.factor | 2 +- core/bootstrap/stage2.factor | 6 +- core/command-line/command-line.factor | 2 +- core/cpu/ppc/architecture/architecture.factor | 16 ++-- core/cpu/ppc/ppc.factor | 9 +-- core/cpu/x86/32/32.factor | 5 +- core/cpu/x86/architecture/architecture.factor | 2 +- core/generator/fixup/fixup.factor | 2 +- core/io/files/files.factor | 12 +-- core/system/system-docs.factor | 60 +++------------ core/system/system-tests.factor | 4 +- core/system/system.factor | 75 ++++++++----------- extra/bootstrap/io/io.factor | 6 +- extra/bootstrap/random/random.factor | 4 +- extra/bootstrap/ui/ui.factor | 6 +- extra/builder/builder.factor | 2 +- extra/cairo/ffi/ffi.factor | 8 +- extra/calendar/calendar.factor | 4 +- .../distributed/distributed-tests.factor | 66 ++++++++-------- extra/db/mysql/ffi/ffi.factor | 6 +- extra/db/postgresql/ffi/ffi.factor | 6 +- extra/db/sqlite/ffi/ffi.factor | 6 +- extra/editors/gvim/gvim.factor | 4 +- extra/freetype/freetype.factor | 4 +- extra/hardware-info/hardware-info.factor | 6 +- extra/io/files/unique/unique.factor | 4 +- extra/io/sockets/impl/impl.factor | 4 +- extra/io/unix/unix.factor | 2 +- extra/io/windows/ce/backend/backend.factor | 2 +- extra/io/windows/launcher/launcher.factor | 4 +- extra/ogg/ogg.factor | 6 +- extra/ogg/theora/theora.factor | 6 +- extra/ogg/vorbis/vorbis.factor | 6 +- extra/openal/openal.factor | 14 ++-- extra/opengl/gl/extensions/extensions.factor | 10 ++- extra/openssl/libcrypto/libcrypto.factor | 6 +- extra/openssl/libssl/libssl.factor | 6 +- extra/oracle/liboci/liboci.factor | 6 +- extra/tools/deploy/deploy.factor | 4 +- extra/tools/disassembler/disassembler.factor | 2 +- extra/ui/tools/deploy/deploy.factor | 2 +- extra/unix/kqueue/kqueue.factor | 2 +- extra/unix/stat/stat.factor | 10 +-- 45 files changed, 186 insertions(+), 239 deletions(-) diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 7bba9d7332..fcafe3441c 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -76,8 +76,8 @@ $nl { $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 ] }" + " { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }" + " { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }" " { [ t ] [ drop ] }" "} cond >>" } diff --git a/core/alien/alien.factor b/core/alien/alien.factor index cfa9fb2e16..56be3e66a5 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -29,7 +29,7 @@ M: f expired? drop t ; f { simple-c-ptr } declare ; inline : alien>native-string ( alien -- string ) - windows? [ alien>u16-string ] [ alien>char-string ] if ; + os windows? [ alien>u16-string ] [ alien>char-string ] if ; : dll-path ( dll -- string ) (dll-path) alien>native-string ; diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index e2fa5833eb..6e0f8e2970 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -13,7 +13,7 @@ IN: bootstrap.image : my-arch ( -- arch ) cpu word-name - dup "ppc" = [ >r os "-" r> 3append ] when ; + dup "ppc" = [ >r os word-name "-" r> 3append ] when ; : boot-image-name ( arch -- string ) "boot." swap ".image" 3append ; diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index bbb2e44843..c82ebbe9f8 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -11,7 +11,7 @@ IN: bootstrap.stage2 SYMBOL: bootstrap-time : default-image-name ( -- string ) - vm file-name windows? [ "." split1 drop ] when + vm file-name os windows? [ "." split1 drop ] when ".image" append resource-path ; : do-crossref ( -- ) @@ -65,8 +65,8 @@ 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 diff --git a/core/command-line/command-line.factor b/core/command-line/command-line.factor index 72c1e063e0..246bf2dabe 100644 --- a/core/command-line/command-line.factor +++ b/core/command-line/command-line.factor @@ -47,7 +47,7 @@ SYMBOL: main-vocab-hook ] bind ; : ignore-cli-args? ( -- ? ) - macosx? "run" get "ui" = and ; + os macosx? "run" get "ui" = and ; : script-mode ( -- ) t "quiet" set-global diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 8055e4ff6e..a1a4bd3809 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -19,14 +19,14 @@ IN: cpu.ppc.architecture : 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 @@ -58,8 +58,8 @@ M: int-regs vregs 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 } ; @@ -273,9 +273,9 @@ M: ppc %cleanup ( alien-node -- ) drop ; 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 fp-shadows-int? ( -- ? ) macosx? ; +M: ppc fp-shadows-int? ( -- ? ) os macosx? ; M: ppc small-enough? ( n -- ? ) -32768 32767 between? ; diff --git a/core/cpu/ppc/ppc.factor b/core/cpu/ppc/ppc.factor index da17da9185..eede86085b 100755 --- a/core/cpu/ppc/ppc.factor +++ b/core/cpu/ppc/ppc.factor @@ -2,16 +2,13 @@ USING: cpu.ppc.architecture cpu.ppc.intrinsics cpu.architecture 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 - -macosx? [ - 4 "double" c-type set-c-type-align -] when diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 3ebee73cbf..4d447b38fc 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -253,12 +253,9 @@ M: x86.32 %cleanup ( alien-node -- ) 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 diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index 76c4f1691a..6c9a4dc05f 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -154,7 +154,7 @@ M: x86 %unbox-small-struct ( size -- ) M: x86 struct-small-enough? ( size -- ? ) { 1 2 4 8 } member? - os { "linux" "netbsd" "solaris" } member? not and ; + os { linux netbsd solaris } member? not and ; M: x86 %return ( -- ) 0 %unwind ; diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 7581377a6a..5cc0442464 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -111,7 +111,7 @@ SYMBOL: literal-table : add-literal ( obj -- n ) literal-table get push-new* ; : string>symbol ( str -- alien ) - [ wince? [ string>u16-alien ] [ string>char-alien ] if ] + [ os wince? [ string>u16-alien ] [ string>char-alien ] if ] over string? [ call ] [ map ] if ; : add-dlsym-literals ( symbol dll -- ) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 720894d489..45bf0602f2 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -43,9 +43,9 @@ HOOK: (file-appender) io-backend ( path -- stream ) >r r> with-stream ; inline ! Pathnames -: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ; +: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ; -: path-separator ( -- string ) windows? "\\" "/" ? ; +: path-separator ( -- string ) os windows? "\\" "/" ? ; : right-trim-separators ( str -- newstr ) [ path-separator? ] right-trim ; @@ -112,7 +112,7 @@ PRIVATE> { { [ dup empty? ] [ f ] } { [ dup "resource:" head? ] [ t ] } - { [ windows? ] [ windows-absolute-path? ] } + { [ os windows? ] [ windows-absolute-path? ] } { [ dup first path-separator? ] [ t ] } { [ t ] [ f ] } } cond nip ; @@ -322,7 +322,7 @@ M: pathname <=> [ pathname-string ] compare ; ! Home directory : home ( -- dir ) { - { [ winnt? ] [ "USERPROFILE" os-env ] } - { [ wince? ] [ "" resource-path ] } - { [ unix? ] [ "HOME" os-env ] } + { [ os winnt? ] [ "USERPROFILE" os-env ] } + { [ os wince? ] [ "" resource-path ] } + { [ os unix? ] [ "HOME" os-env ] } } cond ; diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index 7e7a5ff215..9124efcb8c 100755 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -5,14 +5,8 @@ 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:" @@ -32,23 +26,23 @@ ABOUT: "os" HELP: cpu { $values { "cpu" string } } { $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. Currently, this set of descriptors is:" + { $code x86.32 x86.64 ppc arm } } ; HELP: os { $values { "os" string } } { $description - "Outputs a string descriptor of the current operating system family. Currently, this set of descriptors is:" + "Outputs a singleton class with the name of the current operating system family. Currently, this set of descriptors is:" { $code - "freebsd" - "linux" - "macosx" - "openbsd" - "netbsd" - "solaris" - "wince" - "winnt" + freebsd + linux + macosx + openbsd + netbsd + solaris + wince + winnt } } ; @@ -56,34 +50,6 @@ 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." } ; @@ -135,7 +101,3 @@ HELP: image 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." } ; diff --git a/core/system/system-tests.factor b/core/system/system-tests.factor index 4b074ed7aa..14e34ccb17 100755 --- a/core/system/system-tests.factor +++ b/core/system/system-tests.factor @@ -1,11 +1,11 @@ USING: math tools.test system prettyprint namespaces kernel ; 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 diff --git a/core/system/system.factor b/core/system/system.factor index 459af28537..00b3f87e98 100755 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -4,10 +4,6 @@ IN: system USING: kernel kernel.private sequences math namespaces init splitting assocs system.private layouts words ; -! : cpu ( -- cpu ) 8 getenv ; foldable - -: os ( -- os ) 9 getenv ; foldable - SINGLETON: x86.32 SINGLETON: x86.64 SINGLETON: arm @@ -17,17 +13,23 @@ UNION: x86 x86.32 x86.64 ; : cpu ( -- class ) \ cpu get ; -! SINGLETON: winnt -! SINGLETON: wince +SINGLETON: winnt +SINGLETON: wince -! UNION: windows winnt wince ; +UNION: windows winnt wince ; -! SINGLETON: freebsd -! SINGLETON: netbsd -! SINGLETON: openbsd -! SINGLETON: solaris -! SINGLETON: macosx -! SINGLETON: linux +SINGLETON: freebsd +SINGLETON: netbsd +SINGLETON: openbsd +SINGLETON: solaris +SINGLETON: macosx +SINGLETON: linux + +UNION: bsd freebsd netbsd openbsd macosx ; + +UNION: unix bsd solaris linux ; + +: os ( -- class ) \ os get ; +: string>os ( str -- class ) + H{ + { "winnt" winnt } + { "wince" wince } + { "freebsd" freebsd } + { "netbsd" netbsd } + { "openbsd" openbsd } + { "solaris" solaris } + { "macosx" macosx } + { "linux" linux } + } at ; -! : os ( -- class ) \ os get ; +PRIVATE> [ 8 getenv string>cpu \ cpu set-global - ! 9 getenv string>os \ os set-global + 9 getenv string>os \ os set-global ] "system" add-init-hook : image ( -- path ) 13 getenv ; : vm ( -- path ) 14 getenv ; -: wince? ( -- ? ) - os "wince" = ; foldable - -: winnt? ( -- ? ) - os "winnt" = ; foldable - -: windows? ( -- ? ) - wince? winnt? or ; foldable - : win32? ( -- ? ) - winnt? cell 4 = and ; foldable + os winnt? + cell 4 = and ; foldable : win64? ( -- ? ) - winnt? cell 8 = and ; foldable - -: macosx? ( -- ? ) os "macosx" = ; foldable + os winnt? + cell 8 = and ; foldable : embedded? ( -- ? ) 15 getenv ; -: unix? ( -- ? ) - os { - "freebsd" "openbsd" "netbsd" "linux" "macosx" "solaris" - } member? ; - -: bsd? ( -- ? ) - os { "freebsd" "openbsd" "netbsd" "macosx" } member? ; - -: linux? ( -- ? ) - os "linux" = ; - -: solaris? ( -- ? ) - os "solaris" = ; - : os-envs ( -- assoc ) (os-envs) [ "=" split1 ] H{ } map>assoc ; diff --git a/extra/bootstrap/io/io.factor b/extra/bootstrap/io/io.factor index 065f7dd5c4..a38107fbab 100755 --- a/extra/bootstrap/io/io.factor +++ b/extra/bootstrap/io/io.factor @@ -5,8 +5,8 @@ IN: bootstrap.io "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 diff --git a/extra/bootstrap/random/random.factor b/extra/bootstrap/random/random.factor index daf35b9c03..fa0c54d0c6 100755 --- a/extra/bootstrap/random/random.factor +++ b/extra/bootstrap/random/random.factor @@ -5,8 +5,8 @@ namespaces random ; "random.mersenne-twister" require { - { [ windows? ] [ "random.windows" require ] } - { [ unix? ] [ "random.unix" require ] } + { [ os windows? ] [ "random.windows" require ] } + { [ os unix? ] [ "random.unix" require ] } } cond ! [ [ 32 random-bits ] with-secure-random random-generator set-global ] diff --git a/extra/bootstrap/ui/ui.factor b/extra/bootstrap/ui/ui.factor index f8db831dbc..5aa7683efc 100644 --- a/extra/bootstrap/ui/ui.factor +++ b/extra/bootstrap/ui/ui.factor @@ -4,9 +4,9 @@ vocabs vocabs.loader ; "bootstrap.compiler" vocab [ "ui-backend" get [ { - { [ macosx? ] [ "cocoa" ] } - { [ windows? ] [ "windows" ] } - { [ unix? ] [ "x11" ] } + { [ os macosx? ] [ "cocoa" ] } + { [ os windows? ] [ "windows" ] } + { [ os unix? ] [ "x11" ] } } cond ] unless* "ui." prepend require diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 75664ce5e5..ece6d64ed9 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -245,4 +245,4 @@ USE: bootstrap.image.download ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -MAIN: build-loop \ No newline at end of file +MAIN: build-loop diff --git a/extra/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor index c319ade93b..dd4faf9f96 100644 --- a/extra/cairo/ffi/ffi.factor +++ b/extra/cairo/ffi/ffi.factor @@ -13,10 +13,10 @@ USING: alien alien.syntax combinators system ; IN: cairo.ffi << "cairo" { - { [ win32? ] [ "libcairo-2.dll" ] } - ! { [ macosx? ] [ "libcairo.dylib" ] } - { [ macosx? ] [ "/opt/local/lib/libcairo.dylib" ] } - { [ unix? ] [ "libcairo.so.2" ] } + { [ os win32? ] [ "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 diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 6c29c0d1ac..8dcb4af7f1 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -377,6 +377,6 @@ M: timestamp sleep-until timestamp>millis sleep-until ; M: duration sleep from-now sleep-until ; { - { [ unix? ] [ "calendar.unix" ] } - { [ windows? ] [ "calendar.windows" ] } + { [ os unix? ] [ "calendar.unix" ] } + { [ os windows? ] [ "calendar.windows" ] } } cond require diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor index 856c37a6bc..e2abd6deb9 100755 --- a/extra/concurrency/distributed/distributed-tests.factor +++ b/extra/concurrency/distributed/distributed-tests.factor @@ -1,33 +1,33 @@ -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 - { - { [ unix? ] [ "distributed-concurrency-test" temp-file ] } - { [ windows? ] [ "127.0.0.1" 1238 ] } - } 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 send - - receive -] unit-test - -[ ] [ test-node stop-node ] unit-test +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 ] } + { [ os windows? ] [ "127.0.0.1" 1238 ] } + } 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 send + + receive +] unit-test + +[ ] [ test-node stop-node ] unit-test diff --git a/extra/db/mysql/ffi/ffi.factor b/extra/db/mysql/ffi/ffi.factor index 845381a23c..424cc7c754 100644 --- a/extra/db/mysql/ffi/ffi.factor +++ b/extra/db/mysql/ffi/ffi.factor @@ -6,9 +6,9 @@ USING: alien alien.syntax combinators kernel system ; IN: db.mysql.ffi << "mysql" { - { [ win32? ] [ "libmySQL.dll" "stdcall" ] } - { [ macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] } - { [ unix? ] [ "libmysqlclient.so.14" "cdecl" ] } + { [ os win32? ] [ "libmySQL.dll" "stdcall" ] } + { [ os macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] } + { [ os unix? ] [ "libmysqlclient.so.14" "cdecl" ] } } cond add-library >> LIBRARY: mysql diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index be491b8c85..b6aee3dcce 100755 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -5,9 +5,9 @@ USING: alien alien.syntax combinators system ; IN: db.postgresql.ffi << "postgresql" { - { [ win32? ] [ "libpq.dll" ] } - { [ macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] } - { [ unix? ] [ "libpq.so" ] } + { [ os win32? ] [ "libpq.dll" ] } + { [ os macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] } + { [ os unix? ] [ "libpq.so" ] } } cond "cdecl" add-library >> ! ConnSatusType diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index 1d356b1592..c724025874 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -7,9 +7,9 @@ USING: alien compiler kernel math namespaces sequences strings alien.syntax 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 diff --git a/extra/editors/gvim/gvim.factor b/extra/editors/gvim/gvim.factor index 775d008963..62150bdf49 100755 --- a/extra/editors/gvim/gvim.factor +++ b/extra/editors/gvim/gvim.factor @@ -13,6 +13,6 @@ t vim-detach set-global ! don't block the ui 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 diff --git a/extra/freetype/freetype.factor b/extra/freetype/freetype.factor index 00f7de1370..f34bdc9920 100755 --- a/extra/freetype/freetype.factor +++ b/extra/freetype/freetype.factor @@ -4,8 +4,8 @@ USING: alien alien.syntax kernel system combinators ; 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 >> diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor index 69b8678749..83e59b3123 100755 --- a/extra/hardware-info/hardware-info.factor +++ b/extra/hardware-info/hardware-info.factor @@ -8,9 +8,9 @@ IN: hardware-info << { - { [ windows? ] [ "hardware-info.windows" ] } - { [ linux? ] [ "hardware-info.linux" ] } - { [ macosx? ] [ "hardware-info.macosx" ] } + { [ os windows? ] [ "hardware-info.windows" ] } + { [ os linux? ] [ "hardware-info.linux" ] } + { [ os macosx? ] [ "hardware-info.macosx" ] } { [ t ] [ f ] } } cond [ require ] when* >> diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor index a180a28f23..06a3ec8dd2 100644 --- a/extra/io/files/unique/unique.factor +++ b/extra/io/files/unique/unique.factor @@ -42,6 +42,6 @@ PRIVATE> [ 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 diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor index 8480fcd856..45130c0ab6 100755 --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -6,8 +6,8 @@ alien.c-types combinators namespaces alien parser ; IN: io.sockets.impl << { - { [ windows? ] [ "windows.winsock" ] } - { [ unix? ] [ "unix" ] } + { [ os windows? ] [ "windows.winsock" ] } + { [ os unix? ] [ "unix" ] } } cond use+ >> GENERIC: protocol-family ( addrspec -- af ) diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index 0a7fc72662..f6607d98f9 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -2,4 +2,4 @@ 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." os append require +"io.unix." os word-name append require diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index 152e76a6c7..b8b024d710 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -37,7 +37,7 @@ M: windows-ce-io (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 diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 579745710e..3f230a4ac0 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -82,7 +82,7 @@ TUPLE: CreateProcess-args : 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 ; @@ -105,7 +105,7 @@ M: windows-ce-io 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 diff --git a/extra/ogg/ogg.factor b/extra/ogg/ogg.factor index 830249a3df..9a6997ce29 100644 --- a/extra/ogg/ogg.factor +++ b/extra/ogg/ogg.factor @@ -6,9 +6,9 @@ IN: ogg << "ogg" { - { [ win32? ] [ "ogg.dll" ] } - { [ macosx? ] [ "libogg.0.dylib" ] } - { [ unix? ] [ "libogg.so" ] } + { [ os win32? ] [ "ogg.dll" ] } + { [ os macosx? ] [ "libogg.0.dylib" ] } + { [ os unix? ] [ "libogg.so" ] } } cond "cdecl" add-library >> diff --git a/extra/ogg/theora/theora.factor b/extra/ogg/theora/theora.factor index 48b61b41a3..12d2aa4efb 100644 --- a/extra/ogg/theora/theora.factor +++ b/extra/ogg/theora/theora.factor @@ -6,9 +6,9 @@ IN: ogg.theora << "theora" { - { [ win32? ] [ "theora.dll" ] } - { [ macosx? ] [ "libtheora.0.dylib" ] } - { [ unix? ] [ "libtheora.so" ] } + { [ os win32? ] [ "theora.dll" ] } + { [ os macosx? ] [ "libtheora.0.dylib" ] } + { [ os unix? ] [ "libtheora.so" ] } } cond "cdecl" add-library >> diff --git a/extra/ogg/vorbis/vorbis.factor b/extra/ogg/vorbis/vorbis.factor index 170d0ea6ef..6dbea7869a 100644 --- a/extra/ogg/vorbis/vorbis.factor +++ b/extra/ogg/vorbis/vorbis.factor @@ -6,9 +6,9 @@ IN: ogg.vorbis << "vorbis" { - { [ win32? ] [ "vorbis.dll" ] } - { [ macosx? ] [ "libvorbis.0.dylib" ] } - { [ unix? ] [ "libvorbis.so" ] } + { [ os win32? ] [ "vorbis.dll" ] } + { [ os macosx? ] [ "libvorbis.0.dylib" ] } + { [ os unix? ] [ "libvorbis.so" ] } } cond "cdecl" add-library >> diff --git a/extra/openal/openal.factor b/extra/openal/openal.factor index f7b97d2bf5..e37988a8ce 100644 --- a/extra/openal/openal.factor +++ b/extra/openal/openal.factor @@ -7,15 +7,15 @@ USING: kernel alien system combinators alien.syntax namespaces openal.backend ; << "alut" { - { [ win32? ] [ "alut.dll" ] } - { [ macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] } - { [ unix? ] [ "libalut.so" ] } + { [ os win32? ] [ "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 win32? ] [ "OpenAL32.dll" ] } + { [ os macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] } + { [ os unix? ] [ "libopenal.so" ] } } cond "cdecl" add-library >> LIBRARY: openal @@ -257,7 +257,7 @@ SYMBOL: init "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 diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor index fd9be4eb12..b0a683dac6 100644 --- a/extra/opengl/gl/extensions/extensions.factor +++ b/extra/opengl/gl/extensions/extensions.factor @@ -1,11 +1,13 @@ USING: alien alien.syntax combinators kernel parser sequences system words namespaces hashtables init math arrays assocs sequences.lib continuations ; + +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" ] } + { [ t ] [ unknown-gl-platform ] } } cond use+ >> IN: opengl.gl.extensions diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor index d06afdc5ea..a68cda34ea 100755 --- a/extra/openssl/libcrypto/libcrypto.factor +++ b/extra/openssl/libcrypto/libcrypto.factor @@ -11,9 +11,9 @@ IN: openssl.libcrypto << "libcrypto" { - { [ win32? ] [ "libeay32.dll" "cdecl" ] } - { [ macosx? ] [ "libcrypto.dylib" "cdecl" ] } - { [ unix? ] [ "libcrypto.so" "cdecl" ] } + { [ os win32? ] [ "libeay32.dll" "cdecl" ] } + { [ os macosx? ] [ "libcrypto.dylib" "cdecl" ] } + { [ os unix? ] [ "libcrypto.so" "cdecl" ] } } cond add-library >> diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor index 11dcee31f6..098e1f9382 100755 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ; IN: openssl.libssl << "libssl" { - { [ win32? ] [ "ssleay32.dll" "cdecl" ] } - { [ macosx? ] [ "libssl.dylib" "cdecl" ] } - { [ unix? ] [ "libssl.so" "cdecl" ] } + { [ os win32? ] [ "ssleay32.dll" "cdecl" ] } + { [ os macosx? ] [ "libssl.dylib" "cdecl" ] } + { [ os unix? ] [ "libssl.so" "cdecl" ] } } cond add-library >> : X509_FILETYPE_PEM 1 ; inline diff --git a/extra/oracle/liboci/liboci.factor b/extra/oracle/liboci/liboci.factor index e5313d5b77..6a482b9f56 100644 --- a/extra/oracle/liboci/liboci.factor +++ b/extra/oracle/liboci/liboci.factor @@ -12,9 +12,9 @@ USING: alien alien.syntax combinators kernel system ; 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 win32? ] [ "oci.dll" "stdcall" ] } + { [ os macosx? ] [ "$DYLD_LIBRARY_PATH/libclntsh.dylib" "cdecl" ] } + { [ os unix? ] [ "$DYLD_LIBRARY_PATH/libclntsh.so.10.1" "cdecl" ] } } cond add-library ! =============================================== diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor index f12512f510..893b43844a 100755 --- a/extra/tools/deploy/deploy.factor +++ b/extra/tools/deploy/deploy.factor @@ -5,5 +5,5 @@ IN: tools.deploy : deploy ( vocab -- ) deploy* ; -macosx? [ "tools.deploy.macosx" require ] when -winnt? [ "tools.deploy.windows" require ] when +os macosx? [ "tools.deploy.macosx" require ] when +os winnt? [ "tools.deploy.windows" require ] when diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index 927f7111fa..5b835cd52f 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -27,7 +27,7 @@ M: method-spec make-disassemble-cmd first2 method make-disassemble-cmd ; : gdb-binary ( -- string ) - os "freebsd" = "gdb66" "gdb" ? ; + os freebsd? "gdb66" "gdb" ? ; : run-gdb ( -- lines ) diff --git a/extra/ui/tools/deploy/deploy.factor b/extra/ui/tools/deploy/deploy.factor index eca5740bbc..522c26e92e 100755 --- a/extra/ui/tools/deploy/deploy.factor +++ b/extra/ui/tools/deploy/deploy.factor @@ -49,7 +49,7 @@ TUPLE: deploy-gadget vocab settings ; [ bundle-name deploy-ui - macosx? [ exit-when-windows-closed ] when + os macosx? [ exit-when-windows-closed ] when io-settings reflection-settings advanced-settings diff --git a/extra/unix/kqueue/kqueue.factor b/extra/unix/kqueue/kqueue.factor index 55b53bd6d0..50020072c5 100644 --- a/extra/unix/kqueue/kqueue.factor +++ b/extra/unix/kqueue/kqueue.factor @@ -3,7 +3,7 @@ USING: alien.syntax system sequences vocabs.loader ; IN: unix.kqueue -<< "unix.kqueue." os append require >> +<< "unix.kqueue." os word-name append require >> FUNCTION: int kqueue ( ) ; diff --git a/extra/unix/stat/stat.factor b/extra/unix/stat/stat.factor index f7432332b9..342047d9af 100644 --- a/extra/unix/stat/stat.factor +++ b/extra/unix/stat/stat.factor @@ -60,11 +60,11 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ; << os { - { "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 ] } + { 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 >> From 28d804d2c4916692b4f2589f0f6223929cda46b9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 2 Apr 2008 18:28:55 -0500 Subject: [PATCH 397/886] remove calendar-backend and use os --- extra/calendar/backend/backend.factor | 5 ++--- extra/calendar/unix/unix.factor | 9 ++------- extra/calendar/windows/windows.factor | 8 ++------ 3 files changed, 6 insertions(+), 16 deletions(-) diff --git a/extra/calendar/backend/backend.factor b/extra/calendar/backend/backend.factor index 01c36c65ae..56ccf9e6cc 100644 --- a/extra/calendar/backend/backend.factor +++ b/extra/calendar/backend/backend.factor @@ -1,5 +1,4 @@ -USING: kernel ; +USING: kernel system ; IN: calendar.backend -SYMBOL: calendar-backend -HOOK: gmt-offset calendar-backend ( -- hours minutes seconds ) +HOOK: gmt-offset os ( -- hours minutes seconds ) diff --git a/extra/calendar/unix/unix.factor b/extra/calendar/unix/unix.factor index 2877fa07b5..6383d4ec42 100644 --- a/extra/calendar/unix/unix.factor +++ b/extra/calendar/unix/unix.factor @@ -1,17 +1,12 @@ 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 ( -- alien ) f time localtime ; : timezone-name ( -- string ) get-time tm-zone ; -M: unix-calendar gmt-offset ( -- hours minutes seconds ) +M: unix gmt-offset ( -- hours minutes seconds ) get-time tm-gmtoff 3600 /mod 60 /mod ; diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor index 8548e4ee52..2986422155 100755 --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -1,12 +1,8 @@ -USING: calendar.backend namespaces alien.c-types +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 - -M: windows-calendar gmt-offset ( -- hours minutes seconds ) +M: windows gmt-offset ( -- hours minutes seconds ) "TIME_ZONE_INFORMATION" dup GetTimeZoneInformation { { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error-string throw ] } From 5db2e8570aef4582a1d62aa3a42e2b3c9b61ff5b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 2 Apr 2008 18:30:52 -0500 Subject: [PATCH 398/886] change editors.gvim to use the os singletons --- extra/editors/gvim/unix/unix.factor | 5 +++-- extra/editors/gvim/windows/windows.factor | 4 ++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/extra/editors/gvim/unix/unix.factor b/extra/editors/gvim/unix/unix.factor index a7de09c013..3b8f7454c1 100644 --- a/extra/editors/gvim/unix/unix.factor +++ b/extra/editors/gvim/unix/unix.factor @@ -1,7 +1,8 @@ -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* ; diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor index 489000498e..daf5409c94 100755 --- a/extra/editors/gvim/windows/windows.factor +++ b/extra/editors/gvim/windows/windows.factor @@ -1,8 +1,8 @@ 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" append-path t [ "gvim.exe" tail? ] find-file From 8fde3fb914f178fbe6c2e48077a947640e98a6dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 18:50:21 -0500 Subject: [PATCH 399/886] More inheritance debugging --- core/bootstrap/image/image.factor | 1 + core/bootstrap/primitives.factor | 100 ++++++++++-------- core/bootstrap/stage1.factor | 1 - core/classes/algebra/algebra.factor | 10 +- core/classes/classes.factor | 10 +- core/classes/tuple/tuple-tests.factor | 4 +- core/generic/generic-docs.factor | 7 +- core/generic/generic-tests.factor | 31 ------ core/generic/generic.factor | 43 ++++---- core/generic/math/math.factor | 4 +- .../engines/predicate/predicate.factor | 4 + core/generic/standard/engines/tag/tag.factor | 32 ++++-- .../standard/engines/tuple/tuple.factor | 37 +++++-- core/generic/standard/standard.factor | 39 +++---- core/kernel/kernel.factor | 2 +- core/words/words.factor | 5 +- 16 files changed, 174 insertions(+), 156 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index fc963683b6..f0d9b77981 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -444,6 +444,7 @@ PRIVATE> "resource:/core/bootstrap/stage1.factor" run-file build-image write-image + \ word-props target-word ] with-scope ; : make-images ( -- ) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 48a1117574..6c4462ed98 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -31,6 +31,7 @@ crossref off "syntax" vocab vocab-words bootstrap-syntax set H{ } clone dictionary set H{ } clone changed-words set +H{ } clone forgotten-definitions set H{ } clone root-cache set H{ } clone source-files set H{ } clone update-map set @@ -126,27 +127,49 @@ num-types get f builtins set : register-builtin ( class -- ) [ dup lookup-type-number "type" set-word-prop ] [ dup "type" word-prop builtins get set-nth ] - bi ; + [ f f builtin-class define-class ] + tri ; : define-builtin-slots ( symbol slotspec -- ) [ drop ] [ 1 simple-slots ] 2bi [ "slots" set-word-prop ] [ define-slots ] 2bi ; : define-builtin ( symbol slotspec -- ) - >r - { - [ register-builtin ] - [ f f builtin-class define-class ] - [ define-builtin-predicate ] - [ ] - } cleave + >r [ define-builtin-predicate ] keep r> define-builtin-slots ; -! Forward definitions -"object" "kernel" create t "class" set-word-prop -"object" "kernel" create union-class "metaclass" set-word-prop +"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 -"null" "kernel" create drop +! Catch-all class for providing a default method. +"object" "kernel" create [ drop t ] "predicate" set-word-prop +"object" "kernel" create +f builtins get [ ] subset union-class define-class + +! Class of objects with object tag +"hi-tag" "kernel.private" create +f builtins get num-tags get tail union-class define-class + +! Empty class with no instances +"null" "kernel" create [ drop f ] "predicate" set-word-prop +"null" "kernel" create f { } union-class define-class "fixnum" "math" create { } define-builtin "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop @@ -335,23 +358,25 @@ define-builtin } } define-builtin -"tuple" "kernel" create { } define-builtin - -"tuple" "kernel" lookup -{ - { - { "object" "kernel" } - "delegate" - { "delegate" "kernel" } - { "set-delegate" "kernel" } - } -} -[ drop ] [ generate-tuple-slots ] 2bi -[ [ name>> ] map "slot-names" set-word-prop ] -[ "slots" set-word-prop ] -[ define-slots ] 2tri - -"tuple" "kernel" lookup define-tuple-layout +"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 ! Define general-t type, which is any object that is not f. "general-t" "kernel" create @@ -359,23 +384,10 @@ f "f" "syntax" lookup builtins get remove [ ] subset union-class define-class "f" "syntax" create [ not ] "predicate" set-word-prop -"f?" "syntax" create "syntax" vocab-words delete-at +"f?" "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 -f builtins get [ ] subset union-class define-class - -! Class of objects with object tag -"hi-tag" "kernel.private" create -f builtins get num-tags get tail union-class define-class - -! Null class with no instances. -"null" "kernel" create [ drop f ] "predicate" set-word-prop -"null" "kernel" create f { } union-class define-class +"general-t?" "kernel" vocab-words delete-at ! Create special tombstone values "tombstone" "hashtables.private" create diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 34f758c9df..f99c8eb82f 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -19,7 +19,6 @@ vocabs.loader system debugger continuations ; ! Rehash hashtables, since bootstrap.image creates them ! using the host image's hashing algorithms [ hashtable? ] instances [ rehash ] each - boot ] % diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 5d7c114cbc..97309dbea2 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel classes combinators accessors sequences arrays vectors assocs namespaces words sorting layouts math hashtables -; +kernel.private ; IN: classes.algebra : 2cache ( key1 key2 assoc quot -- value ) @@ -211,12 +211,6 @@ C: anonymous-complement : 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 -- assoc ) flatten-class [ dup tuple class< [ 2drop tuple tuple ] when @@ -229,5 +223,5 @@ C: anonymous-complement : class-tags ( class -- tag/f ) class-types [ dup num-tags get >= - [ drop object tag-number ] when + [ drop \ hi-tag tag-number ] when ] map prune ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 914e070e03..0baf235edb 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -25,9 +25,11 @@ SYMBOL: class-or-cache class-and-cache get clear-assoc class-or-cache get clear-assoc ; -PREDICATE: class < word ( obj -- ? ) "class" word-prop ; - SYMBOL: update-map + +PREDICATE: class < word + "class" word-prop ; + SYMBOL: builtins PREDICATE: builtin-class < class @@ -58,7 +60,7 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ; dup class? [ "superclass" word-prop ] [ drop f ] if ; : superclasses ( class -- supers ) - [ dup ] [ dup superclass swap ] [ ] unfold reverse nip ; + [ dup ] [ [ superclass ] keep ] [ ] unfold nip reverse ; : members ( class -- seq ) #! Output f for non-classes to work with algebra code @@ -72,7 +74,7 @@ M: word reset-class drop ; ! update-map : class-uses ( class -- seq ) - dup members swap superclass [ suffix ] when* ; + [ members ] [ superclass ] bi [ suffix ] when* ; : class-usages ( class -- assoc ) [ update-map get at ] closure ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 228de8aabf..ff34c25416 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -394,7 +394,9 @@ test-server-slot-values ! Reshape crash TUPLE: test1 a ; TUPLE: test2 < test1 b ; -T{ test2 f "a" "b" } "test" set +C: test2 + +"a" "b" "test" set : test-a/b [ "a" ] [ "test" get a>> ] unit-test diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 100475455a..04252b6b3b 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -37,7 +37,6 @@ $nl { $subsection create-method } "Method definitions can be looked up:" { $subsection method } -{ $subsection methods } "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:" @@ -120,10 +119,6 @@ HELP: { $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." } ; @@ -151,4 +146,4 @@ HELP: forget-methods { $values { "class" class } } { $description "Remove all method definitions which specialize on the class." } ; -{ sort-classes methods order } related-words +{ sort-classes order } related-words diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 6a7f8f29fc..fd313d8165 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -171,37 +171,6 @@ M: f tag-and-f 4 ; [ 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 diff --git a/core/generic/generic.factor b/core/generic/generic.factor index dc98883654..2ec285146e 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -25,8 +25,9 @@ PREDICATE: generic < word 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 ; @@ -37,13 +38,6 @@ PREDICATE: method-spec < pair : order ( generic -- seq ) "methods" word-prop keys sort-classes ; -: sort-methods ( assoc -- assoc' ) - [ keys sort-classes ] - [ [ dupd at ] curry ] bi { } map>assoc ; - -: methods ( word -- assoc ) - "methods" word-prop sort-methods ; - TUPLE: check-method class generic ; : check-method ( class generic -- class generic ) @@ -64,6 +58,9 @@ PREDICATE: method-body < word 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 @@ -122,9 +119,12 @@ M: method-body definer 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 + forget-method + ] + [ t "forgotten" set-word-prop ] bi ] if ; : implementors* ( classes -- words ) @@ -137,12 +137,13 @@ M: method-body forget* 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 update-map- - forget-word ; + [ forget-methods ] + [ update-map- ] + [ forget-word ] + tri ; M: assoc update-methods ( assoc -- ) implementors* [ make-generic ] each ; @@ -158,11 +159,15 @@ M: assoc update-methods ( assoc -- ) ] if ; M: generic subwords - dup "methods" word-prop values - swap "default-method" word-prop suffix ; + [ + [ "default-method" word-prop , ] + [ "methods" word-prop values % ] + [ "engines" word-prop % ] + tri + ] { } make ; M: generic forget-word - dup subwords [ forget ] each (forget-word) ; + [ subwords forget-all ] [ (forget-word) ] bi ; : xref-generics ( -- ) all-words [ subwords [ xref ] each ] each ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 85bd736139..2fda2c9621 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -71,13 +71,15 @@ M: math-combination make-default-method 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: math-generic < generic ( word -- ? ) "combination" word-prop math-combination? ; diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor index 2d43a313f0..ce7d5c6c21 100644 --- a/core/generic/standard/engines/predicate/predicate.factor +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -21,6 +21,10 @@ C: predicate-dispatch-engine { [ t ] [ [ 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 diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index 3dd8b83579..6344bec536 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/core/generic/standard/engines/tag/tag.factor @@ -1,26 +1,27 @@ USING: classes.private generic.standard.engines namespaces arrays assocs sequences.private quotations kernel.private -layouts math slots.private math.private kernel accessors ; +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 -TUPLE: hi-tag-dispatch-engine methods ; - -C: hi-tag-dispatch-engine - -: convert-hi-tag-methods ( assoc -- assoc' ) - \ hi-tag \ convert-methods ; - : direct-dispatch-quot ( alist n -- quot ) default get [ 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 tag-number r> ] assoc-map + methods>> engines>quots* [ >r lo-tag-number r> ] assoc-map [ picker % [ tag ] % [ linear-dispatch-quot @@ -29,12 +30,21 @@ M: lo-tag-dispatch-engine engine>quot ] if-small? % ] [ ] make ; +TUPLE: hi-tag-dispatch-engine methods ; + +C: hi-tag-dispatch-engine + +: convert-hi-tag-methods ( assoc -- assoc' ) + \ hi-tag bootstrap-word + \ convert-methods ; + : num-hi-tags num-types get num-tags get - ; -: hi-tag-number type-number num-tags get - ; +: hi-tag-number ( class -- n ) + "type" word-prop num-tags get - ; : hi-tag-quot ( -- quot ) - [ 0 slot ] num-tags get [ fixnum- ] curry compose ; + [ 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 diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index ce0f50337d..510d5ef732 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -2,7 +2,7 @@ IN: generic.standard.engines.tuple 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 quotations ; +classes.algebra math math.private quotations arrays ; TUPLE: echelon-dispatch-engine n methods ; @@ -27,17 +27,25 @@ TUPLE: tuple-dispatch-engine echelons ; : ( methods -- engine ) echelon-sort - [ dupd ] assoc-map + [ + over zero? [ + dup assoc-empty? + [ drop f ] [ values first ] if + ] [ + dupd + ] if + ] assoc-map [ nip ] assoc-subset \ tuple-dispatch-engine construct-boa ; : convert-tuple-methods ( assoc -- assoc' ) - tuple \ convert-methods ; + tuple bootstrap-word + \ convert-methods ; M: trivial-tuple-dispatch-engine engine>quot methods>> engines>quots* linear-dispatch-quot ; : hash-methods ( methods -- buckets ) - >alist V{ } clone [ class-hashes ] distribute-buckets + >alist V{ } clone [ hashcode 1array ] distribute-buckets [ ] map ; : class-hash-dispatch-quot ( methods -- quot ) @@ -60,12 +68,20 @@ PREDICATE: tuple-dispatch-engine-word < word M: tuple-dispatch-engine-word stack-effect "tuple-dispatch-generic" word-prop stack-effect ; +M: tuple-dispatch-engine-word crossref? + drop t ; + +: remember-engine ( word -- ) + generic get "engines" word-prop push ; + : ( engine -- word ) tuple-dispatch-engine-word-name f - [ t "tuple-dispatch-engine" set-word-prop ] - [ generic get "tuple-dispatch-generic" set-word-prop ] - [ ] - tri ; + { + [ t "tuple-dispatch-engine" set-word-prop ] + [ generic get "tuple-dispatch-generic" set-word-prop ] + [ remember-engine ] + [ ] + } cleave ; : define-tuple-dispatch-engine-word ( engine quot -- word ) >r dup r> define ; @@ -104,6 +120,9 @@ M: tuple-dispatch-engine engine>quot picker % [ 1 slot 5 slot ] % echelons>> - [ [ engine>quot dup default set ] assoc-map ] with-scope + [ + tuple assumed set + [ engine>quot dup default set ] assoc-map + ] with-scope >=-case-quot % ] [ ] make ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 1de41f24ed..0d29bdecd5 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -59,29 +59,32 @@ ERROR: no-method object generic ; : find-default ( methods -- quot ) #! Side-effects methods. - object swap delete-at* [ + object bootstrap-word swap delete-at* [ drop generic get "default-method" word-prop 1quotation ] unless ; GENERIC: mangle-method ( method generic -- quot ) -: single-combination ( words -- quot ) +: single-combination ( word -- quot ) [ - object bootstrap-word assumed set - [ generic set ] - [ - "methods" word-prop - [ generic get mangle-method ] assoc-map - [ find-default default set ] + object bootstrap-word assumed set { + [ generic set ] + [ "engines" word-prop forget-all ] + [ V{ } clone "engines" set-word-prop ] [ - generic get "inline" word-prop [ - - ] [ - - ] if - ] bi - engine>quot - ] bi + "methods" word-prop + [ generic get mangle-method ] assoc-map + [ find-default default set ] + [ + generic get "inline" word-prop [ + + ] [ + + ] if + ] bi + engine>quot + ] + } cleave ] with-scope ; TUPLE: standard-combination # ; @@ -107,7 +110,7 @@ M: standard-combination make-default-method [ empty-method ] with-standard ; M: standard-combination perform-combination - [ single-combination ] with-standard ; + [ drop ] [ [ single-combination ] with-standard ] 2bi define ; TUPLE: hook-combination var ; @@ -128,7 +131,7 @@ M: hook-combination make-default-method [ error-method ] with-hook ; M: hook-combination perform-combination - [ single-combination ] with-hook ; + [ drop ] [ [ single-combination ] with-hook ] 2bi define ; GENERIC: dispatch# ( word -- n ) diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index eed5b22e5f..ae775ec116 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -194,7 +194,7 @@ GENERIC: construct-boa ( ... class -- tuple ) Date: Wed, 2 Apr 2008 18:50:35 -0500 Subject: [PATCH 400/886] Don't JIT inside heap scan loop, too fragile --- vm/data_gc.c | 1 - vm/factor.c | 24 +++++++++++++++++++----- vm/run.c | 7 +++++-- 3 files changed, 24 insertions(+), 8 deletions(-) diff --git a/vm/data_gc.c b/vm/data_gc.c index 0a1fad575a..24f7cfecb9 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -730,7 +730,6 @@ void garbage_collection(CELL gen, /* collect objects referenced from stacks and environment */ collect_roots(); - /* collect objects referenced from older generations */ collect_cards(); diff --git a/vm/factor.c b/vm/factor.c index 20667a23f5..5825f97bdd 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -36,22 +36,36 @@ void do_stage1_init(void) fprintf(stderr,"*** Stage 2 early init... "); fflush(stderr); + GROWABLE_ARRAY(words); + begin_scan(); CELL obj; while((obj = next_object()) != F) { if(type_of(obj) == WORD_TYPE) - { - F_WORD *word = untag_object(obj); - default_word_code(word,false); - update_word_xt(word); - } + GROWABLE_ADD(words,obj); } /* End heap scan */ gc_off = false; + GROWABLE_TRIM(words); + REGISTER_ROOT(words); + + CELL i; + CELL length = array_capacity(untag_object(words)); + for(i = 0; i < length; i++) + { + 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); + } + + UNREGISTER_ROOT(words); + iterate_code_heap(relocate_code_block); userenv[STAGE2_ENV] = T; diff --git a/vm/run.c b/vm/run.c index d03d999ffd..cec19b5445 100755 --- a/vm/run.c +++ b/vm/run.c @@ -22,8 +22,11 @@ void fix_stacks(void) 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 */ From 93ebbfb7e4e39835d06daf2582044d73facda692 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 18:50:42 -0500 Subject: [PATCH 401/886] Try to fix inotify again --- extra/io/unix/linux/linux.factor | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 2ae4065fb6..0c79ce970d 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -24,8 +24,10 @@ TUPLE: inotify watches ; : ( -- port/f ) H{ } clone - inotify_init [ io-error ] [ inotify ] bi - { set-inotify-watches set-delegate } inotify construct ; + inotify_init dup 0 < [ 2drop f ] [ + inotify + { set-inotify-watches set-delegate } inotify construct + ] if ; : inotify-fd inotify get-global handle>> ; @@ -109,9 +111,12 @@ TUPLE: inotify-task ; f inotify-task ; : init-inotify ( mx -- ) - - dup inotify set-global - swap register-io-task ; + dup [ + dup inotify set-global + swap register-io-task + ] [ + 2drop + ] if ; M: inotify-task do-io-task ( task -- ) io-task-port read-notifications f ; @@ -119,7 +124,7 @@ M: inotify-task do-io-task ( task -- ) M: linux-io init-io ( -- ) [ mx set-global ] - [ [ init-inotify ] curry ignore-errors ] bi ; + [ init-inotify ] bi ; T{ linux-io } set-io-backend From a9cd31704daa40b2d5a013613f2f39d9de59d7a9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 2 Apr 2008 18:53:24 -0500 Subject: [PATCH 402/886] remove win32? and win64? words --- core/alien/c-types/c-types.factor | 2 +- core/system/system-docs.factor | 10 -------- core/system/system.factor | 8 ------ extra/cairo/ffi/ffi.factor | 4 +-- extra/db/mysql/ffi/ffi.factor | 2 +- extra/db/postgresql/ffi/ffi.factor | 2 +- extra/ogg/ogg.factor | 2 +- extra/ogg/theora/theora.factor | 2 +- extra/ogg/vorbis/vorbis.factor | 2 +- extra/openal/backend/backend.factor | 8 ++---- extra/openal/macosx/macosx.factor | 32 +++++++++++------------- extra/openal/openal.factor | 16 ++++++------ extra/openal/other/other.factor | 28 ++++++++++----------- extra/openssl/libcrypto/libcrypto.factor | 2 +- extra/openssl/libssl/libssl.factor | 2 +- extra/oracle/liboci/liboci.factor | 2 +- 16 files changed, 49 insertions(+), 75 deletions(-) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index ae99f9e6bf..ca1a89b4ae 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -388,6 +388,6 @@ M: long-long-type box-return ( 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 diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index 9124efcb8c..9d25ee1138 100755 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -5,8 +5,6 @@ IN: system ARTICLE: "os" "System interface" "Operating system detection:" { $subsection os } -{ $subsection win32? } -{ $subsection win64? } "Processor detection:" { $subsection cpu } "Reading environment variables:" @@ -86,14 +84,6 @@ HELP: set-os-envs { os-env os-envs set-os-envs } related-words -HELP: win32? -{ $values { "?" "a boolean" } } -{ $description "Tests if Factor is running on 32-bit Windows." } ; - -HELP: win64? -{ $values { "?" "a boolean" } } -{ $description "Tests if Factor is running on 64-bit Windows." } ; - HELP: image { $values { "path" "a pathname string" } } { $description "Outputs the pathname of the currently running Factor image." } ; diff --git a/core/system/system.factor b/core/system/system.factor index 00b3f87e98..98dc605acc 100755 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -64,14 +64,6 @@ PRIVATE> : vm ( -- path ) 14 getenv ; -: win32? ( -- ? ) - os winnt? - cell 4 = and ; foldable - -: win64? ( -- ? ) - os winnt? - cell 8 = and ; foldable - : embedded? ( -- ? ) 15 getenv ; : os-envs ( -- assoc ) diff --git a/extra/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor index dd4faf9f96..200c85c929 100644 --- a/extra/cairo/ffi/ffi.factor +++ b/extra/cairo/ffi/ffi.factor @@ -7,13 +7,11 @@ ! - most of the matrix stuff ! - most of the query functions - USING: alien alien.syntax combinators system ; - IN: cairo.ffi << "cairo" { - { [ os win32? ] [ "libcairo-2.dll" ] } + { [ os winnt? ] [ "libcairo-2.dll" ] } ! { [ os macosx? ] [ "libcairo.dylib" ] } { [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] } { [ os unix? ] [ "libcairo.so.2" ] } diff --git a/extra/db/mysql/ffi/ffi.factor b/extra/db/mysql/ffi/ffi.factor index 424cc7c754..c047393c99 100644 --- a/extra/db/mysql/ffi/ffi.factor +++ b/extra/db/mysql/ffi/ffi.factor @@ -6,7 +6,7 @@ USING: alien alien.syntax combinators kernel system ; IN: db.mysql.ffi << "mysql" { - { [ os win32? ] [ "libmySQL.dll" "stdcall" ] } + { [ os winnt? ] [ "libmySQL.dll" "stdcall" ] } { [ os macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] } { [ os unix? ] [ "libmysqlclient.so.14" "cdecl" ] } } cond add-library >> diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index b6aee3dcce..7925989bf5 100755 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -5,7 +5,7 @@ USING: alien alien.syntax combinators system ; IN: db.postgresql.ffi << "postgresql" { - { [ os win32? ] [ "libpq.dll" ] } + { [ os winnt? ] [ "libpq.dll" ] } { [ os macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] } { [ os unix? ] [ "libpq.so" ] } } cond "cdecl" add-library >> diff --git a/extra/ogg/ogg.factor b/extra/ogg/ogg.factor index 9a6997ce29..37dd30f7fd 100644 --- a/extra/ogg/ogg.factor +++ b/extra/ogg/ogg.factor @@ -6,7 +6,7 @@ IN: ogg << "ogg" { - { [ os win32? ] [ "ogg.dll" ] } + { [ os winnt? ] [ "ogg.dll" ] } { [ os macosx? ] [ "libogg.0.dylib" ] } { [ os unix? ] [ "libogg.so" ] } } cond "cdecl" add-library diff --git a/extra/ogg/theora/theora.factor b/extra/ogg/theora/theora.factor index 12d2aa4efb..3d73fb8820 100644 --- a/extra/ogg/theora/theora.factor +++ b/extra/ogg/theora/theora.factor @@ -6,7 +6,7 @@ IN: ogg.theora << "theora" { - { [ os win32? ] [ "theora.dll" ] } + { [ os winnt? ] [ "theora.dll" ] } { [ os macosx? ] [ "libtheora.0.dylib" ] } { [ os unix? ] [ "libtheora.so" ] } } cond "cdecl" add-library diff --git a/extra/ogg/vorbis/vorbis.factor b/extra/ogg/vorbis/vorbis.factor index 6dbea7869a..5712272ebc 100644 --- a/extra/ogg/vorbis/vorbis.factor +++ b/extra/ogg/vorbis/vorbis.factor @@ -6,7 +6,7 @@ IN: ogg.vorbis << "vorbis" { - { [ os win32? ] [ "vorbis.dll" ] } + { [ os winnt? ] [ "vorbis.dll" ] } { [ os macosx? ] [ "libvorbis.0.dylib" ] } { [ os unix? ] [ "libvorbis.so" ] } } cond "cdecl" add-library diff --git a/extra/openal/backend/backend.factor b/extra/openal/backend/backend.factor index edbb227fcc..41069dcddf 100644 --- a/extra/openal/backend/backend.factor +++ b/extra/openal/backend/backend.factor @@ -1,8 +1,4 @@ -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 ) diff --git a/extra/openal/macosx/macosx.factor b/extra/openal/macosx/macosx.factor index 7828021f53..c03ad5693c 100644 --- a/extra/openal/macosx/macosx.factor +++ b/extra/openal/macosx/macosx.factor @@ -1,18 +1,14 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -IN: openal.macosx -USING: alien.c-types kernel alien alien.syntax shuffle -combinators.lib openal.backend namespaces ; - -TUPLE: macosx-openal-backend ; -LIBRARY: alut - -T{ macosx-openal-backend } openal-backend set-global - -FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ; - -M: macosx-openal-backend load-wav-file ( path -- format data size frequency ) - 0 f 0 0 - [ 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. +USING: alien.c-types kernel alien alien.syntax shuffle +combinators.lib openal.backend namespaces ; +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 f 0 0 + [ alutLoadWAVFile ] 4keep + >r >r >r *int r> *void* r> *int r> *int ; diff --git a/extra/openal/openal.factor b/extra/openal/openal.factor index e37988a8ce..ff67a30ea3 100644 --- a/extra/openal/openal.factor +++ b/extra/openal/openal.factor @@ -1,20 +1,23 @@ ! 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" { - { [ os win32? ] [ "alut.dll" ] } - { [ os macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] } + { [ os windows? ] [ "alut.dll" ] } + { [ os macosx? ] [ + "/System/Library/Frameworks/OpenAL.framework/OpenAL" + ] } { [ os unix? ] [ "libalut.so" ] } } cond "cdecl" add-library >> << "openal" { - { [ os win32? ] [ "OpenAL32.dll" ] } - { [ os macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] } + { [ os windows? ] [ "OpenAL32.dll" ] } + { [ os macosx? ] [ + "/System/Library/Frameworks/OpenAL.framework/OpenAL" + ] } { [ os unix? ] [ "libopenal.so" ] } } cond "cdecl" add-library >> @@ -290,4 +293,3 @@ os macosx? "openal.macosx" "openal.other" ? require : source-playing? ( source -- bool ) AL_SOURCE_STATE get-source-param AL_PLAYING = ; - diff --git a/extra/openal/other/other.factor b/extra/openal/other/other.factor index e32b007973..d0429fb3c3 100644 --- a/extra/openal/other/other.factor +++ b/extra/openal/other/other.factor @@ -1,14 +1,14 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -IN: openal.other -USING: openal.backend alien.c-types kernel alien alien.syntax shuffle combinators.lib ; - -LIBRARY: alut - -FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ; - -M: other-openal-backend load-wav-file ( filename -- format data size frequency ) - 0 f 0 0 - [ 0 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. +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 f 0 0 + [ 0 alutLoadWAVFile ] 4keep + >r >r >r *int r> *void* r> *int r> *int ; diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor index a68cda34ea..312c7b04b3 100755 --- a/extra/openssl/libcrypto/libcrypto.factor +++ b/extra/openssl/libcrypto/libcrypto.factor @@ -11,7 +11,7 @@ IN: openssl.libcrypto << "libcrypto" { - { [ os win32? ] [ "libeay32.dll" "cdecl" ] } + { [ os winnt? ] [ "libeay32.dll" "cdecl" ] } { [ os macosx? ] [ "libcrypto.dylib" "cdecl" ] } { [ os unix? ] [ "libcrypto.so" "cdecl" ] } } cond add-library diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor index 098e1f9382..0f2e7b3184 100755 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -10,7 +10,7 @@ USING: alien alien.syntax combinators kernel system ; IN: openssl.libssl << "libssl" { - { [ os win32? ] [ "ssleay32.dll" "cdecl" ] } + { [ os winnt? ] [ "ssleay32.dll" "cdecl" ] } { [ os macosx? ] [ "libssl.dylib" "cdecl" ] } { [ os unix? ] [ "libssl.so" "cdecl" ] } } cond add-library >> diff --git a/extra/oracle/liboci/liboci.factor b/extra/oracle/liboci/liboci.factor index 6a482b9f56..7af69a97bb 100644 --- a/extra/oracle/liboci/liboci.factor +++ b/extra/oracle/liboci/liboci.factor @@ -12,7 +12,7 @@ USING: alien alien.syntax combinators kernel system ; IN: oracle.liboci "oci" { - { [ os win32? ] [ "oci.dll" "stdcall" ] } + { [ 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 From 0d8a27e5e43f9d45b84bc0f3baeaf77495a26a55 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 2 Apr 2008 19:23:26 -0500 Subject: [PATCH 403/886] update docs --- core/system/system-docs.factor | 60 ++++++++++++++++++----------- extra/help/handbook/handbook.factor | 2 +- 2 files changed, 39 insertions(+), 23 deletions(-) diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index 9d25ee1138..df112bd786 100755 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -1,12 +1,12 @@ 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 } -"Processor detection:" -{ $subsection cpu } +ABOUT: "system" + +ARTICLE: "system" "System interface" +{ $subsection "cpu" } +{ $subsection "os" } "Reading environment variables:" { $subsection os-env } { $subsection os-envs } @@ -19,29 +19,45 @@ ARTICLE: "os" "System interface" { $subsection exit } { $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ; -ABOUT: "os" +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 singleton class with the name 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 singleton class with the name 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? diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 1c2dfde85c..e45c49aa25 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -261,7 +261,7 @@ ARTICLE: "handbook" "Factor documentation" { $subsection "collections" } { $subsection "io" } { $subsection "concurrency" } -{ $subsection "os" } +{ $subsection "system" } { $subsection "alien" } { $heading "Environment reference" } { $subsection "cli" } From de30882cb1b74ac77df1188f0103f5cb0593cf7f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 2 Apr 2008 19:23:37 -0500 Subject: [PATCH 404/886] fix load error --- extra/hardware-info/hardware-info.factor | 4 +--- extra/hardware-info/windows/windows.factor | 4 ++-- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor index 83e59b3123..ecdcc42cb5 100755 --- a/extra/hardware-info/hardware-info.factor +++ b/extra/hardware-info/hardware-info.factor @@ -6,11 +6,9 @@ IN: hardware-info : megs. ( x -- ) 20 2^ /f . ; : gigs. ( x -- ) 30 2^ /f . ; -<< -{ +<< { { [ os windows? ] [ "hardware-info.windows" ] } { [ os linux? ] [ "hardware-info.linux" ] } { [ os macosx? ] [ "hardware-info.macosx" ] } { [ t ] [ f ] } } cond [ require ] when* >> - diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index f3a1eb33f5..807fd158ba 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -65,6 +65,6 @@ IN: hardware-info.windows << { - { [ 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* >> From 83d9b936b2ca8bbb17b972ec9db444aed0ec69bc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 2 Apr 2008 19:44:01 -0500 Subject: [PATCH 405/886] change ui backends to singletons --- extra/ui/cocoa/cocoa.factor | 4 ++-- extra/ui/windows/windows.factor | 4 ++-- extra/ui/x11/x11.factor | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 79b7041dcb..59adcf9af1 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -12,7 +12,7 @@ TUPLE: handle view window ; C: handle -TUPLE: cocoa-ui-backend ; +SINGLETON: cocoa-ui-backend SYMBOL: stop-after-last-window? @@ -119,6 +119,6 @@ M: cocoa-ui-backend ui ] 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 diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index f47a82275b..e0c9f24122 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -10,7 +10,7 @@ shuffle opengl ui.render unicode.case ascii math.bitfields locals symbols ; 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 ; @@ -496,6 +496,6 @@ M: windows-ui-backend ui ] [ 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 diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index eaf87acace..9445486656 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -8,7 +8,7 @@ io.encodings.utf8 combinators debugger system command-line ui.render math.vectors classes.tuple opengl.gl threads ; IN: ui.x11 -TUPLE: x11-ui-backend ; +SINGLETON: x11-ui-backend : XA_NET_WM_NAME "_NET_WM_NAME" x-atom ; @@ -259,7 +259,7 @@ M: x11-ui-backend ui ( -- ) ] with-x ] ui-running ; -T{ x11-ui-backend } ui-backend set-global +x11-ui-backend ui-backend set-global [ "DISPLAY" os-env "ui" "listener" ? ] main-vocab-hook set-global From 72c06fc028e56dd39f657b6c1f31494dd631a88a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 2 Apr 2008 19:46:37 -0500 Subject: [PATCH 406/886] use OS symbol in deploy --- extra/tools/deploy/backend/backend.factor | 4 +--- extra/tools/deploy/macosx/macosx.factor | 6 +----- extra/tools/deploy/windows/windows.factor | 6 +----- 3 files changed, 3 insertions(+), 13 deletions(-) diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 395c4ff924..e11d16c4ec 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -107,6 +107,4 @@ DEFER: ?make-staging-image make-boot-image deploy-command-line run-factor ; -SYMBOL: deploy-implementation - -HOOK: deploy* deploy-implementation ( vocab -- ) +HOOK: deploy* os ( vocab -- ) diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 6d9c8e9d8a..3a7f8e5d03 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -50,17 +50,13 @@ IN: tools.deploy.macosx : 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 rot parent-directory -> selectFile:inFileViewerRootedAtPath: drop ; -M: macosx-deploy-implementation deploy* ( vocab -- ) +M: macosx deploy* ( vocab -- ) ".app deploy tool" assert.app "resource:" [ dup deploy-config [ diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor index 1c9a8195c5..33ab877ee1 100755 --- a/extra/tools/deploy/windows/windows.factor +++ b/extra/tools/deploy/windows/windows.factor @@ -25,11 +25,7 @@ IN: tools.deploy.windows : image-name ( vocab bundle-name -- str ) prepend-path ".image" append ; -TUPLE: windows-deploy-implementation ; - -T{ windows-deploy-implementation } deploy-implementation set-global - -M: windows-deploy-implementation deploy* +M: winnt deploy* "." resource-path [ dup deploy-config [ [ deploy-name get create-exe-dir ] keep From c53e75ef0f54f52a86659eb3ec39f18bdcc2bf43 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 2 Apr 2008 20:09:56 -0500 Subject: [PATCH 407/886] io backend now uses OS singletons --- extra/io/unix/backend/backend.factor | 8 ++--- extra/io/unix/bsd/bsd.factor | 10 ++---- extra/io/unix/files/files.factor | 32 ++++++++++---------- extra/io/unix/files/unique/unique.factor | 6 ++-- extra/io/unix/freebsd/freebsd.factor | 9 ++---- extra/io/unix/launcher/launcher.factor | 8 ++--- extra/io/unix/linux/linux.factor | 10 ++---- extra/io/unix/macosx/macosx.factor | 12 +++----- extra/io/unix/netbsd/netbsd.factor | 9 ++---- extra/io/unix/openbsd/openbsd.factor | 9 ++---- extra/io/windows/ce/backend/backend.factor | 8 ++--- extra/io/windows/ce/ce.factor | 16 ++++++---- extra/io/windows/ce/files/files.factor | 8 ++--- extra/io/windows/ce/sockets/sockets.factor | 16 +++++----- extra/io/windows/files/files.factor | 8 ++--- extra/io/windows/files/unique/unique.factor | 4 +-- extra/io/windows/launcher/launcher.factor | 10 +++--- extra/io/windows/mmap/mmap.factor | 10 +++--- extra/io/windows/nt/backend/backend.factor | 10 +++--- extra/io/windows/nt/files/files.factor | 14 ++++----- extra/io/windows/nt/launcher/launcher.factor | 4 +-- extra/io/windows/nt/monitors/monitors.factor | 4 +-- extra/io/windows/nt/nt.factor | 3 +- extra/io/windows/nt/sockets/sockets.factor | 16 +++++----- extra/io/windows/windows.factor | 30 ++++++++---------- 25 files changed, 123 insertions(+), 151 deletions(-) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 63d2adbdf7..865490b0ce 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -8,8 +8,6 @@ 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 ; @@ -120,7 +118,7 @@ M: integer close-handle ( fd -- ) [ 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 @@ -180,10 +178,10 @@ M: write-task do-io-task M: port port-flush ( port -- ) dup 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 1 2 ; diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index 89b0757da5..6f6517868e 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -3,7 +3,7 @@ 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 ; +threads continuations system ; ! On Mac OS X, we use select() for the top-level ! multiplexer, and we hang a kqueue off of it for process exit @@ -12,16 +12,12 @@ threads continuations ; ! 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 ( -- ) mx set-global kqueue-mx set-global kqueue-mx get-global dup io-task-fd 2dup mx get-global mx-reads set-at mx get-global mx-writes set-at ; -M: bsd-io register-process ( process -- ) +M: bsd register-process ( process -- ) process-handle kqueue-mx get-global add-pid-task ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 7d0e7c4330..f6bb3edcde 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -3,15 +3,15 @@ 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 calendar -io.encodings.binary accessors sequences strings ; +io.encodings.binary accessors sequences strings system ; IN: io.unix.files -M: unix-io cwd ( -- path ) +M: unix cwd ( -- path ) MAXPATHLEN [ ] [ ] bi getcwd [ (io-error) ] unless* ; -M: unix-io cd ( path -- ) +M: unix cd ( path -- ) chdir io-error ; : read-flags O_RDONLY ; inline @@ -19,7 +19,7 @@ M: unix-io cd ( path -- ) : 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 ; : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline @@ -27,7 +27,7 @@ M: unix-io (file-reader) ( path -- stream ) : 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 ; : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline @@ -36,28 +36,28 @@ M: unix-io (file-writer) ( path -- stream ) 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 ; : 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 -- ) +M: unix move-file ( from to -- ) [ normalize-path ] bi@ rename io-error ; -M: unix-io delete-file ( path -- ) +M: unix delete-file ( path -- ) normalize-path unlink io-error ; -M: unix-io make-directory ( path -- ) +M: unix make-directory ( path -- ) normalize-path OCT: 777 mkdir io-error ; -M: unix-io delete-directory ( path -- ) +M: unix delete-directory ( path -- ) normalize-path rmdir io-error ; : (copy-file) ( from to -- ) @@ -68,7 +68,7 @@ M: unix-io delete-directory ( path -- ) ] 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 ] @@ -95,16 +95,16 @@ M: unix-io copy-file ( from to -- ) } cleave \ file-info construct-boa ; -M: unix-io file-info ( path -- info ) +M: unix file-info ( path -- info ) normalize-path stat* stat>file-info ; -M: unix-io link-info ( path -- info ) +M: unix link-info ( path -- info ) normalize-path lstat* stat>file-info ; -M: unix-io make-link ( path1 path2 -- ) +M: unix make-link ( path1 path2 -- ) normalize-path symlink io-error ; -M: unix-io read-link ( path -- path' ) +M: unix read-link ( path -- path' ) normalize-path PATH_MAX [ tuck ] [ ] bi readlink dup io-error head-slice >string ; diff --git a/extra/io/unix/files/unique/unique.factor b/extra/io/unix/files/unique/unique.factor index c5365d8d5c..035e6398ee 100644 --- a/extra/io/unix/files/unique/unique.factor +++ b/extra/io/unix/files/unique/unique.factor @@ -1,11 +1,11 @@ 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 -- ) +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" ; diff --git a/extra/io/unix/freebsd/freebsd.factor b/extra/io/unix/freebsd/freebsd.factor index 65b4a6f0f7..49fbc9af7e 100644 --- a/extra/io/unix/freebsd/freebsd.factor +++ b/extra/io/unix/freebsd/freebsd.factor @@ -1,8 +1,3 @@ -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 diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 4986024e78..8e5531a40c 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -79,12 +79,12 @@ USE: unix (io-error) ] [ 255 exit ] recover ; -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 ) @@ -95,7 +95,7 @@ M: unix-io kill-process* ( pid -- ) 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 ] diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 2ae4065fb6..9f135f2958 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -7,10 +7,6 @@ namespaces threads continuations init math alien.c-types alien vocabs.loader accessors ; IN: io.unix.linux -TUPLE: linux-io ; - -INSTANCE: linux-io unix-io - TUPLE: linux-monitor ; : ( wd -- monitor ) @@ -50,7 +46,7 @@ TUPLE: inotify watches ; "inotify is not supported by this Linux release" throw ] unless ; -M: linux-io ( path recursive? -- monitor ) +M: linux ( path recursive? -- monitor ) check-inotify drop IN_CHANGE_EVENTS add-watch ; @@ -116,11 +112,11 @@ TUPLE: inotify-task ; M: inotify-task do-io-task ( task -- ) io-task-port read-notifications f ; -M: linux-io init-io ( -- ) +M: linux init-io ( -- ) [ mx set-global ] [ [ init-inotify ] curry ignore-errors ] bi ; -T{ linux-io } set-io-backend +linux set-io-backend [ start-wait-thread ] "io.unix.linux" add-init-hook diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor index bd48fbc9b5..c1c73ea018 100644 --- a/extra/io/unix/macosx/macosx.factor +++ b/extra/io/unix/macosx/macosx.factor @@ -1,13 +1,9 @@ -IN: io.unix.macosx USING: io.unix.bsd io.backend io.monitors io.monitors.private continuations kernel core-foundation.fsevents sequences -namespaces arrays ; +namespaces arrays system ; +IN: io.unix.macosx -TUPLE: macosx-io ; - -INSTANCE: macosx-io bsd-io - -T{ macosx-io } set-io-backend +macosx set-io-backend TUPLE: macosx-monitor ; @@ -16,7 +12,7 @@ TUPLE: macosx-monitor ; [ [ first { +modify-file+ } swap changed-file ] each ] bind notify-callback ; -M: macosx-io +M: macosx drop f macosx-monitor construct-simple-monitor dup [ enqueue-notifications ] curry diff --git a/extra/io/unix/netbsd/netbsd.factor b/extra/io/unix/netbsd/netbsd.factor index 3aa8678702..c5771c8ffc 100644 --- a/extra/io/unix/netbsd/netbsd.factor +++ b/extra/io/unix/netbsd/netbsd.factor @@ -1,8 +1,3 @@ -IN: io.unix.netbsd -USING: io.unix.bsd io.backend ; +USING: io.backend system ; -TUPLE: netbsd-io ; - -INSTANCE: netbsd-io bsd-io - -T{ netbsd-io } set-io-backend +netbsd set-io-backend diff --git a/extra/io/unix/openbsd/openbsd.factor b/extra/io/unix/openbsd/openbsd.factor index 767861ec75..9b3021646d 100644 --- a/extra/io/unix/openbsd/openbsd.factor +++ b/extra/io/unix/openbsd/openbsd.factor @@ -1,8 +1,3 @@ -IN: io.unix.openbsd -USING: io.unix.bsd io.backend core-foundation.fsevents ; +USING: io.unix.bsd io.backend core-foundation.fsevents system ; -TUPLE: openbsd-io ; - -INSTANCE: openbsd-io bsd-io - -T{ openbsd-io } set-io-backend +openbsd set-io-backend diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index b8b024d710..a8ff4c14e3 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -7,10 +7,10 @@ IN: io.windows.ce.backend : 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 -- ) @@ -26,14 +26,14 @@ M: port port-flush 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 [ diff --git a/extra/io/windows/ce/ce.factor b/extra/io/windows/ce/ce.factor index 878f5899f6..a0a8de8513 100755 --- a/extra/io/windows/ce/ce.factor +++ b/extra/io/windows/ce/ce.factor @@ -1,7 +1,11 @@ -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 diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor index 1e5cedae57..8f7390aa7c 100755 --- a/extra/io/windows/ce/files/files.factor +++ b/extra/io/windows/ce/files/files.factor @@ -1,15 +1,15 @@ 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-path ( 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 ; diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor index 9bc583a3d8..0001bb5142 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -2,11 +2,11 @@ USING: alien alien.c-types combinators io io.backend io.buffers 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 @@ -31,15 +31,15 @@ M: win32-socket wince-write ( port port-handle -- ) 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 dup ; -M: windows-ce-io (server) ( addrspec -- handle ) +M: wince (server) ( addrspec -- handle ) windows.winsock:SOCK_STREAM server-fd dup listen-on-socket ; -M: windows-ce-io (accept) ( server -- client ) +M: wince (accept) ( server -- client ) [ dup check-server-port [ @@ -55,7 +55,7 @@ M: windows-ce-io (accept) ( server -- client ) ] with-timeout ; -M: windows-ce-io ( addrspec -- datagram ) +M: wince ( addrspec -- datagram ) [ windows.winsock:SOCK_DGRAM server-fd ] keep ; @@ -81,7 +81,7 @@ M: windows-ce-io ( addrspec -- datagram ) packet-size 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 @@ -104,7 +104,7 @@ M: windows-ce-io receive ( datagram -- packet addrspec ) 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 diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index a23a78b3da..4f31d2dfce 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -3,7 +3,7 @@ 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 -combinators.lib io.nonblocking destructors ; +combinators.lib io.nonblocking destructors system ; IN: io.windows.files SYMBOLS: +read-only+ +hidden+ +system+ @@ -88,10 +88,10 @@ SYMBOLS: +read-only+ +hidden+ +system+ get-file-information BY_HANDLE_FILE_INFORMATION>file-info ] if ; -M: windows-nt-io file-info ( path -- info ) +M: winnt file-info ( path -- info ) normalize-path get-file-information-stat ; -M: windows-nt-io link-info ( path -- info ) +M: winnt link-info ( path -- info ) file-info ; : file-times ( path -- timestamp timestamp timestamp ) @@ -125,7 +125,7 @@ M: windows-nt-io link-info ( path -- info ) : set-file-write-time ( path timestamp -- ) >r f f r> set-file-times ; -M: windows-nt-io touch-file ( path -- ) +M: winnt touch-file ( path -- ) [ normalize-path maybe-create-file over close-always diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor index 7e7610eb72..0449980286 100644 --- a/extra/io/windows/files/unique/unique.factor +++ b/extra/io/windows/files/unique/unique.factor @@ -2,9 +2,9 @@ USING: kernel system io.files.unique.backend windows.kernel32 io.windows io.nonblocking windows ; IN: io.windows.files.unique -M: windows-io (make-unique-file) ( path -- ) +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 ; diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 3f230a4ac0..2724966a8f 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -101,7 +101,7 @@ TUPLE: CreateProcess-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 @@ -111,10 +111,10 @@ M: windows-ce-io fill-redirection 2drop ; 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 ) [ dup make-CreateProcess-args tuck fill-redirection @@ -122,7 +122,7 @@ M: windows-io run-process* ( process -- handle ) lpProcessInformation>> ] with-destructors ; -M: windows-io kill-process* ( handle -- ) +M: windows kill-process* ( handle -- ) PROCESS_INFORMATION-hProcess 255 TerminateProcess win32-error=0/f ; @@ -161,7 +161,7 @@ SYMBOL: wait-flag wait-flag set-global [ wait-loop t ] "Process wait" spawn-server drop ; -M: windows-io register-process +M: windows register-process drop wait-flag get-global raise-flag ; [ start-wait-thread ] "io.windows.launcher" add-init-hook diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index d1cafa4c0f..8d3690bbb5 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -1,7 +1,7 @@ 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 @@ -53,11 +53,11 @@ 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 ) @@ -70,7 +70,7 @@ M: windows-ce-io with-privileges dup close-later ] with-privileges ; -M: windows-io ( path length -- mmap ) +M: windows ( path length -- mmap ) [ swap GENERIC_WRITE GENERIC_READ bitor @@ -81,7 +81,7 @@ M: windows-io ( path length -- mmap ) f \ mapped-file construct-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 diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index dcd13895b2..822973b85b 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -3,7 +3,7 @@ continuations destructors io io.backend io.nonblocking io.windows libc kernel math namespaces sequences threads classes.tuple.lib windows windows.errors windows.kernel32 strings splitting io.files qualified ascii -combinators.lib ; +combinators.lib system ; QUALIFIED: windows.winsock IN: io.windows.nt.backend @@ -28,7 +28,7 @@ SYMBOL: master-completion-port : ( -- handle ) INVALID_HANDLE_VALUE f ; -M: windows-nt-io add-completion ( handle -- ) +M: winnt add-completion ( handle -- ) master-completion-port get-global drop ; : eof? ( error -- ? ) @@ -89,13 +89,13 @@ M: windows-nt-io add-completion ( handle -- ) : drain-overlapped ( timeout -- ) handle-overlapped [ 0 drain-overlapped ] unless ; -M: windows-nt-io cancel-io +M: winnt cancel-io port-handle win32-file-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 set-global H{ } clone io-hash set-global windows.winsock:init-winsock ; diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 91ad0139b2..7bac540ddc 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,22 +1,22 @@ 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 +kernel libc math threads windows windows.kernel32 system alien.c-types alien.arrays sequences combinators combinators.lib sequences.lib ascii splitting alien strings assocs namespaces ; IN: io.windows.nt.files -M: windows-nt-io cwd +M: winnt cwd MAX_UNICODE_PATH dup "ushort" [ GetCurrentDirectory win32-error=0/f ] keep alien>u16-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 -- ? ) +M: winnt root-directory? ( path -- ? ) { { [ dup empty? ] [ f ] } { [ dup [ path-separator? ] all? ] [ t ] } @@ -40,15 +40,15 @@ ERROR: not-absolute-path ; unicode-prefix prepend ] unless ; -M: windows-nt-io normalize-path ( string -- string' ) +M: winnt normalize-path ( string -- string' ) (normalize-path) { { CHAR: / CHAR: \\ } } substitute 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 -- ) diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index 895890e898..4bbf7c8e32 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -112,13 +112,13 @@ IN: io.windows.nt.launcher 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) [ dup make-CreateProcess-args diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index 83e062c3a9..164b529b61 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -5,7 +5,7 @@ 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 ; +combinators math.bitfields strings system ; IN: io.windows.nt.monitors : open-directory ( path -- handle ) @@ -30,7 +30,7 @@ TUPLE: win32-monitor path recursive? ; set-delegate } win32-monitor construct ; -M: windows-nt-io ( path recursive? -- monitor ) +M: winnt ( path recursive? -- monitor ) [ over open-directory win32-monitor diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index 1baec5658f..33bb3a88b9 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -11,5 +11,6 @@ USE: io.windows.nt.sockets USE: io.windows.mmap USE: io.windows.files USE: io.backend +USE: system -T{ windows-nt-io } set-io-backend +winnt set-io-backend diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 85bb34b225..36acaac992 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -2,13 +2,13 @@ USING: alien alien.accessors alien.c-types byte-arrays 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 classes.tuple.lib ; +threads classes.tuple.lib system ; 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* ) @@ -50,7 +50,7 @@ TUPLE: ConnectEx-args port 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 over make-sockaddr/size pick init-connect @@ -119,7 +119,7 @@ TUPLE: AcceptEx-args port [ AcceptEx-args-sAcceptSocket* add-completion ] keep AcceptEx-args-sAcceptSocket* ; -M: windows-nt-io (accept) ( server -- addrspec handle ) +M: winnt (accept) ( server -- addrspec handle ) [ [ dup check-server-port @@ -131,14 +131,14 @@ M: windows-nt-io (accept) ( server -- addrspec handle ) ] 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 ] with-destructors ; -M: windows-nt-io ( addrspec -- datagram ) +M: winnt ( addrspec -- datagram ) [ [ SOCK_DGRAM server-fd @@ -190,7 +190,7 @@ TUPLE: WSARecvFrom-args port [ 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 @@ -242,7 +242,7 @@ TUPLE: WSASendTo-args port 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 diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 45c1adaf50..7755f111c6 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -5,16 +5,12 @@ io.buffers io.files io.nonblocking io.sockets io.binary 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 ; 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 ; @@ -24,7 +20,7 @@ HOOK: CreateFile-flags io-backend ( DWORD -- DWORD ) HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) HOOK: add-completion io-backend ( port -- ) -M: windows-io normalize-directory ( string -- string ) +M: windows normalize-directory ( string -- string ) normalize-path "\\" ?tail drop "\\*" append ; : share-mode ( -- fixnum ) @@ -125,30 +121,30 @@ C: FileArgs [ FileArgs-lpNumberOfBytesRet ] keep FileArgs-lpOverlapped ; -M: windows-io (file-reader) ( path -- stream ) +M: windows (file-reader) ( path -- stream ) open-read ; -M: windows-io (file-writer) ( path -- stream ) +M: windows (file-writer) ( path -- stream ) open-write ; -M: windows-io (file-appender) ( path -- stream ) +M: windows (file-appender) ( path -- stream ) open-append ; -M: windows-io move-file ( from to -- ) +M: windows move-file ( from to -- ) [ normalize-path ] bi@ MoveFile win32-error=0/f ; -M: windows-io delete-file ( path -- ) +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-path ] bi@ 0 CopyFile win32-error=0/f ; -M: windows-io make-directory ( path -- ) +M: windows make-directory ( path -- ) normalize-path f CreateDirectory win32-error=0/f ; -M: windows-io delete-directory ( path -- ) +M: windows delete-directory ( path -- ) normalize-path RemoveDirectory win32-error=0/f ; @@ -194,7 +190,7 @@ USE: namespaces 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 ) From 5de68cd30f3bcf16177aab4344feeeebaa4c5c1e Mon Sep 17 00:00:00 2001 From: erg Date: Wed, 2 Apr 2008 20:33:36 -0500 Subject: [PATCH 408/886] fix bootstrap on intel mac --- extra/io/unix/mmap/mmap.factor | 4 ++-- extra/io/unix/sockets/sockets.factor | 16 ++++++++-------- extra/io/unix/unix.factor | 2 +- extra/unix/bsd/bsd.factor | 8 ++++---- extra/unix/kqueue/kqueue.factor | 2 +- extra/unix/types/types.factor | 23 ++++++++++------------- extra/unix/unix.factor | 6 +++--- 7 files changed, 29 insertions(+), 32 deletions(-) diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor index 71c55f2303..f042366b13 100755 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -10,12 +10,12 @@ IN: io.unix.mmap >r f -roll r> open-r/w [ 0 mmap ] keep over MAP_FAILED = [ close (io-error) ] when ; -M: unix-io ( path length -- obj ) +M: unix ( path length -- obj ) swap >r dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor r> mmap-open f mapped-file construct-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 diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 69ce6a3069..477757e0ed 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -7,7 +7,7 @@ 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 io.backend io.files ; +combinators io.backend io.files system ; IN: io.unix.sockets : pending-init-error ( port -- ) @@ -23,7 +23,7 @@ IN: io.unix.sockets : sockopt ( fd level opt -- ) 1 "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 @@ -42,7 +42,7 @@ M: connect-task do-io-task : wait-to-connect ( port -- ) [ 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 @@ -91,11 +91,11 @@ USE: io.sockets 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 @@ -104,7 +104,7 @@ M: unix-io (accept) ( server -- addrspec handle ) swap server-port-client ; ! Datagram sockets - UDP and Unix domain -M: unix-io +M: unix [ SOCK_DGRAM server-fd ] keep ; SYMBOL: receive-buffer @@ -147,7 +147,7 @@ M: receive-task do-io-task : wait-receive ( stream -- ) [ add-io-task ] with-port-continuation drop ; -M: unix-io receive ( datagram -- packet addrspec ) +M: unix receive ( datagram -- packet addrspec ) dup check-datagram-port dup wait-receive dup pending-error @@ -179,7 +179,7 @@ M: send-task do-io-task [ add-io-task ] with-port-continuation 2drop 2drop ; -M: unix-io send ( packet addrspec datagram -- ) +M: unix send ( packet addrspec datagram -- ) 3dup check-datagram-send [ >r make-sockaddr/size r> wait-send ] keep pending-error ; diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index f6607d98f9..b4328f31b3 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,5 +1,5 @@ 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 ; +system vocabs.loader sequences words ; "io.unix." os word-name append require diff --git a/extra/unix/bsd/bsd.factor b/extra/unix/bsd/bsd.factor index 6cb5d6385b..d80db44348 100755 --- a/extra/unix/bsd/bsd.factor +++ b/extra/unix/bsd/bsd.factor @@ -73,8 +73,8 @@ C-STRUCT: sockaddr-un : 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 ] } + { macosx [ "unix.bsd.macosx" require ] } + { freebsd [ "unix.bsd.freebsd" require ] } + { openbsd [ "unix.bsd.openbsd" require ] } + { netbsd [ "unix.bsd.netbsd" require ] } } case diff --git a/extra/unix/kqueue/kqueue.factor b/extra/unix/kqueue/kqueue.factor index 50020072c5..080820ebd0 100644 --- a/extra/unix/kqueue/kqueue.factor +++ b/extra/unix/kqueue/kqueue.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax system sequences vocabs.loader ; +USING: alien.syntax system sequences vocabs.loader words ; IN: unix.kqueue << "unix.kqueue." os word-name append require >> diff --git a/extra/unix/types/types.factor b/extra/unix/types/types.factor index 983d5d677d..0ac2fa608e 100644 --- a/extra/unix/types/types.factor +++ b/extra/unix/types/types.factor @@ -1,17 +1,14 @@ - -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 ] } - { "openbsd" [ "unix.types.openbsd" require ] } - { "netbsd" [ "unix.types.netbsd" require ] } - { "winnt" [ ] } - } -case +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 diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index ffd102901c..e911a5c039 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -161,8 +161,8 @@ FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; { - { [ linux? ] [ "unix.linux" require ] } - { [ bsd? ] [ "unix.bsd" require ] } - { [ solaris? ] [ "unix.solaris" require ] } + { [ os linux? ] [ "unix.linux" require ] } + { [ os bsd? ] [ "unix.bsd" require ] } + { [ os solaris? ] [ "unix.solaris" require ] } } cond From f10f601e3f17fe2a437f1badfe5638946084a225 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 2 Apr 2008 20:50:20 -0500 Subject: [PATCH 409/886] fix teh bootstrap --- extra/io/unix/linux/linux.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 9f135f2958..a452878a43 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -4,7 +4,7 @@ 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 accessors ; +vocabs.loader accessors system ; IN: io.unix.linux TUPLE: linux-monitor ; From 5346e1899f2fea2bccdad4ed55adbb6cfd471160 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 21:27:49 -0500 Subject: [PATCH 410/886] Working on call-next-method, and identity-tuple --- core/bootstrap/compiler/compiler.factor | 6 --- core/bootstrap/image/image.factor | 1 - core/bootstrap/primitives.factor | 25 +++++------ core/bootstrap/syntax.factor | 1 + core/classes/algebra/algebra-tests.factor | 4 +- core/classes/classes-docs.factor | 1 - core/classes/classes-tests.factor | 9 +++- core/classes/classes.factor | 5 ++- core/classes/tuple/tuple-docs.factor | 8 ---- core/classes/tuple/tuple-tests.factor | 31 +++++++++++++ core/classes/tuple/tuple.factor | 44 ++++++++----------- core/compiler/compiler-docs.factor | 15 +++++-- core/compiler/compiler.factor | 6 +++ core/definitions/definitions-tests.factor | 2 +- core/generic/generic-tests.factor | 23 ---------- core/generic/generic.factor | 23 +++++----- core/generic/math/math.factor | 4 +- .../standard/engines/tuple/tuple.factor | 2 +- core/generic/standard/standard.factor | 37 ++++++++++++---- core/inference/class/class-tests.factor | 14 +++++- core/inference/class/class.factor | 17 +++++-- core/inference/dataflow/dataflow.factor | 9 ++-- .../transforms/transforms-tests.factor | 5 ++- core/inference/transforms/transforms.factor | 10 ++++- core/kernel/kernel-docs.factor | 40 ++++++++++------- core/kernel/kernel.factor | 44 +++++++++++-------- core/optimizer/control/control.factor | 2 +- core/optimizer/inlining/inlining.factor | 12 ++++- core/optimizer/known-words/known-words.factor | 2 +- core/optimizer/math/math.factor | 2 +- core/parser/parser.factor | 12 ++++- core/prettyprint/prettyprint-tests.factor | 2 - core/sequences/sequences.factor | 3 ++ core/syntax/syntax-docs.factor | 2 +- core/syntax/syntax.factor | 6 +++ core/vocabs/vocabs.factor | 8 +--- core/words/words.factor | 2 +- extra/io/launcher/launcher.factor | 4 +- extra/io/sockets/impl/impl.factor | 9 ++-- extra/models/models.factor | 5 +-- extra/ui/freetype/freetype.factor | 5 +-- extra/ui/gadgets/gadgets.factor | 8 ++-- extra/ui/gadgets/worlds/worlds.factor | 4 +- 43 files changed, 279 insertions(+), 195 deletions(-) diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 7d4db3c473..035d95d3ab 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -16,12 +16,6 @@ IN: bootstrap.compiler "cpu." cpu append require -: enable-compiler ( -- ) - [ optimized-recompile-hook ] recompile-hook set-global ; - -: disable-compiler ( -- ) - [ default-recompile-hook ] recompile-hook set-global ; - enable-compiler nl diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index f0d9b77981..fc963683b6 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -444,7 +444,6 @@ PRIVATE> "resource:/core/bootstrap/stage1.factor" run-file build-image write-image - \ word-props target-word ] with-scope ; : make-images ( -- ) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 6c4462ed98..f3846de5b1 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -159,17 +159,24 @@ num-types get f builtins set "tuple-layout" "classes.tuple.private" create register-builtin ! Catch-all class for providing a default method. -"object" "kernel" create [ drop t ] "predicate" set-word-prop "object" "kernel" create -f builtins get [ ] subset union-class define-class +[ f builtins get [ ] subset union-class define-class ] +[ [ drop t ] "predicate" set-word-prop ] +bi + +"object?" "kernel" vocab-words delete-at ! Class of objects with object tag "hi-tag" "kernel.private" create -f builtins get num-tags get tail union-class define-class +builtins get num-tags get tail define-union-class ! Empty class with no instances -"null" "kernel" create [ drop f ] "predicate" set-word-prop -"null" "kernel" create f { } union-class define-class +"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 @@ -378,17 +385,9 @@ define-builtin ] } cleave -! Define general-t type, which is any object that is not f. -"general-t" "kernel" create -f "f" "syntax" lookup builtins get remove [ ] subset union-class -define-class - "f" "syntax" create [ not ] "predicate" set-word-prop "f?" "syntax" vocab-words delete-at -"general-t" "kernel" create [ ] "predicate" set-word-prop -"general-t?" "kernel" vocab-words delete-at - ! Create special tombstone values "tombstone" "hashtables.private" create "tuple" "kernel" lookup diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index e7e90d8dd0..b3e5cb0120 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -66,6 +66,7 @@ IN: bootstrap.syntax "CS{" "<<" ">>" + "call-next-method" } [ "syntax" create drop ] each "t" "syntax" lookup define-symbol diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 32664dc823..0f468908a9 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -23,8 +23,8 @@ random inference effects kernel.private ; [ t ] [ number object number class-and* ] unit-test [ t ] [ object number number class-and* ] unit-test [ t ] [ slice reversed null class-and* ] unit-test -[ t ] [ general-t \ f null class-and* ] unit-test -[ t ] [ general-t \ f object class-or* ] unit-test +[ t ] [ \ f class-not \ f null class-and* ] unit-test +[ t ] [ \ f class-not \ f object class-or* ] unit-test TUPLE: first-one ; TUPLE: second-one ; diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 9573de8949..0560a0e755 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -21,7 +21,6 @@ $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 } diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index ae9e6ec154..ae19f38d14 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate classes.algebra vectors definitions source-files -compiler.units ; +compiler.units kernel.private ; IN: classes.tests ! DEFER: bah @@ -153,3 +153,10 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2 ! 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 diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 0baf235edb..c45fd7360b 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -60,7 +60,7 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ; dup class? [ "superclass" word-prop ] [ drop f ] if ; : superclasses ( class -- supers ) - [ dup ] [ [ superclass ] keep ] [ ] unfold nip reverse ; + [ superclass ] follow reverse ; : members ( class -- seq ) #! Output f for non-classes to work with algebra code @@ -133,3 +133,6 @@ GENERIC: class ( object -- class ) M: hi-tag class hi-tag type>class ; M: object class tag type>class ; + +: instance? ( obj class -- ? ) + "predicate" word-prop call ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 18c8143654..664f0545fa 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -153,14 +153,6 @@ HELP: tuple= { $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: removed-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-removed-slots -{ $values { "class" tuple-class } { "slots" "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 diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index ff34c25416..735f328a67 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -511,3 +511,34 @@ USE: vocabs define-tuple-class ] with-compilation-unit ] unit-test + +[ "USE: words T{ word }" eval ] [ [ no-method? ] is? ] must-fail-with + +! Accessors not being forgotten... +[ [ ] ] [ + "IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;" + + "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" + + "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 diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index bbc221b85d..ac1a7b8849 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -19,7 +19,7 @@ ERROR: no-tuple-class class ; GENERIC: tuple-layout ( object -- layout ) -M: class tuple-layout "layout" word-prop ; +M: tuple-class tuple-layout "layout" word-prop ; M: tuple tuple-layout 1 slot ; @@ -40,7 +40,9 @@ PRIVATE> [ drop ] [ no-tuple-class ] if ; : tuple>array ( tuple -- array ) - prepare-tuple>array >r copy-tuple-slots r> layout-class prefix ; + prepare-tuple>array + >r copy-tuple-slots r> + layout-class prefix ; : tuple-slots ( tuple -- array ) prepare-tuple>array drop copy-tuple-slots ; @@ -120,15 +122,6 @@ PRIVATE> : define-tuple-layout ( class -- ) dup make-tuple-layout "layout" set-word-prop ; -: removed-slots ( class newslots -- seq ) - swap slot-names seq-diff ; - -: forget-removed-slots ( class slots -- ) - dupd removed-slots [ - [ reader-word forget-method ] - [ writer-word forget-method ] 2bi - ] with each ; - : all-slot-names ( class -- slots ) superclasses [ slot-names ] map concat \ class prefix ; @@ -189,9 +182,8 @@ M: tuple-class update-class tri ] each-subclass ] - [ nip forget-removed-slots ] [ define-new-tuple-class ] - 3tri ; + 3bi ; : tuple-class-unchanged? ( class superclass slots -- ? ) rot tuck [ superclass = ] [ slot-names = ] 2bi* and ; @@ -213,7 +205,19 @@ M: tuple-class define-tuple-class dup [ construct-boa throw ] curry define ; M: tuple-class reset-class - { "metaclass" "superclass" "slots" "layout" } reset-props ; + [ + dup "slot-names" word-prop [ + [ reader-word forget-method ] + [ writer-word forget-method ] 2bi + ] with each + ] [ + { + "metaclass" + "superclass" + "layout" + "slots" + } reset-props + ] bi ; M: tuple clone (clone) dup delegate clone over set-delegate ; @@ -228,12 +232,6 @@ M: tuple hashcode* ] 2curry reduce ] recursive-hashcode ; -M: object construct-empty ( class -- tuple ) - tuple-layout ; - -M: object construct-boa ( ... class -- tuple ) - tuple-layout ; - ! Deprecated M: object get-slots ( obj slots -- ... ) [ execute ] with each ; @@ -241,10 +239,6 @@ M: object get-slots ( obj slots -- ... ) M: object set-slots ( ... obj slots -- ) get-slots ; -M: object construct ( ... slots class -- tuple ) - construct-empty [ swap set-slots ] keep ; - -: delegates ( obj -- seq ) - [ dup ] [ [ delegate ] keep ] [ ] unfold nip ; +: delegates ( obj -- seq ) [ delegate ] follow ; : is? ( obj quot -- ? ) >r delegates r> contains? ; inline diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index 3520104e1f..341d56f1d5 100755 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -2,14 +2,21 @@ USING: generator help.markup help.syntax words io parser 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 } -"These words are not usually used directly. Instead, use " { $link "compilation-units" } "." ; +"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:" diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 111d84cde0..a0599f79a1 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -56,5 +56,11 @@ IN: compiler 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 ; diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index ebbce4d7e2..3dc28139ea 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -4,7 +4,7 @@ compiler.units words ; TUPLE: combination-1 ; -M: combination-1 perform-combination 2drop [ ] ; +M: combination-1 perform-combination drop [ ] define ; M: combination-1 make-default-method 2drop [ "No method" throw ] ; diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index fd313d8165..524835f461 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -21,19 +21,6 @@ M: word class-of drop "word" ; [ "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 ; @@ -51,16 +38,6 @@ 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 ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 2ec285146e..b0099f770c 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -6,16 +6,7 @@ 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 ) @@ -38,6 +29,18 @@ PREDICATE: method-spec < pair : order ( generic -- seq ) "methods" word-prop keys sort-classes ; +: 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 ) + +: (call-next-method) ( class generic -- ) + next-method-quot call ; + TUPLE: check-method class generic ; : check-method ( class generic -- class generic ) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 2fda2c9621..46208744f0 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -12,9 +12,9 @@ PREDICATE: math-class < class 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 null class< ] [ drop { -1 -1 } ] } { [ dup math-class? ] [ class-types last/first ] } diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 510d5ef732..40e749f473 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -15,7 +15,7 @@ C: trivial-tuple-dispatch-engine TUPLE: tuple-dispatch-engine echelons ; : push-echelon ( class method assoc -- ) - >r swap dup tuple-layout layout-echelon r> + >r swap dup "layout" word-prop layout-echelon r> [ ?set-at ] change-at ; : echelon-sort ( assoc -- assoc' ) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 0d29bdecd5..2b2dbd2b2d 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -8,6 +8,10 @@ generic.standard.engines.tag generic.standard.engines.predicate generic.standard.engines.tuple accessors ; IN: generic.standard +GENERIC: dispatch# ( word -- n ) + +M: word dispatch# "combination" word-prop dispatch# ; + : unpickers { [ nip ] @@ -101,7 +105,7 @@ PREDICATE: simple-generic < standard-generic T{ standard-combination f 0 } define-generic ; : with-standard ( combination quot -- quot' ) - >r #>> (dispatch#) r> with-variable ; + >r #>> (dispatch#) r> with-variable ; inline M: standard-generic mangle-method drop 1quotation ; @@ -112,6 +116,27 @@ M: standard-combination make-default-method M: standard-combination perform-combination [ drop ] [ [ single-combination ] with-standard ] 2bi define ; +M: standard-combination dispatch# #>> ; + +ERROR: inconsistent-next-method object class generic ; + +ERROR: no-next-method class generic ; + +M: standard-generic next-method-quot + [ + [ + [ [ instance? ] curry ] + [ dispatch# (picker) ] bi* prepend % + ] + [ + 2dup next-method + [ 2nip 1quotation ] + [ [ no-next-method ] 2curry ] if* , + ] + [ [ inconsistent-next-method ] 2curry , ] + 2tri + ] [ ] make ; + TUPLE: hook-combination var ; C: hook-combination @@ -124,6 +149,8 @@ PREDICATE: hook-generic < generic dip var>> [ get ] curry prepend ] with-variable ; inline +M: hook-combination dispatch# drop 0 ; + M: hook-generic mangle-method drop 1quotation [ drop ] prepend ; @@ -133,14 +160,6 @@ M: hook-combination make-default-method M: hook-combination perform-combination [ drop ] [ [ single-combination ] with-hook ] 2bi define ; -GENERIC: dispatch# ( word -- n ) - -M: word dispatch# "combination" word-prop dispatch# ; - -M: standard-combination dispatch# #>> ; - -M: hook-combination dispatch# drop 0 ; - M: simple-generic definer drop \ GENERIC: f ; M: standard-generic definer drop \ GENERIC# f ; diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 7d18aaa489..b54dbe256a 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -21,7 +21,7 @@ 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 ) @@ -297,3 +297,15 @@ cell-bits 32 = [ [ t ] [ [ { vector } declare nth-unsafe ] \ nth-unsafe inlined? ] unit-test + +[ t ] [ + [ + dup integer? [ + dup fixnum? [ + 1 + + ] [ + 2 + + ] if + ] when + ] \ + inlined? +] unit-test diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 4aac98ce41..8269952409 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -176,9 +176,18 @@ M: pair constraint-satisfied? : 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 [ @@ -209,7 +218,7 @@ M: #push infer-classes-before M: #if child-constraints [ - general-t 0 `input class, + \ f class-not 0 `input class, f 0 `input literal, ] make-constraints ; diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 7fa2fbbcd3..01c0a9c5f4 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -9,15 +9,13 @@ IN: inference.dataflow : \ counter ; ! Literal value -TUPLE: value literal uid recursion ; +TUPLE: value < identity-tuple literal uid recursion ; : ( obj -- value ) recursive-state get value construct-boa ; M: value hashcode* nip value-uid ; -M: value equal? 2drop f ; - ! Result of curry TUPLE: curried obj quot ; @@ -30,13 +28,12 @@ C: composed 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 -- ) diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index cb8024d3c5..3fc8f37b4f 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -1,6 +1,7 @@ IN: inference.transforms.tests USING: sequences inference.transforms tools.test math kernel -quotations inference accessors combinators words arrays ; +quotations inference accessors combinators words arrays +classes ; : compose-n-quot >quotation ; : compose-n compose-n-quot call ; @@ -56,3 +57,5 @@ C: color [ 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 diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 06c2a8f476..d95ff9c3bc 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -3,7 +3,7 @@ USING: arrays kernel words sequences generic math namespaces quotations assocs combinators math.bitfields inference.backend inference.dataflow inference.state classes.tuple.private effects -inspector hashtables ; +inspector hashtables classes generic ; IN: inference.transforms : pop-literals ( n -- rstate seq ) @@ -98,3 +98,11 @@ M: duplicated-slots-error summary \ construct-empty 1 1 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 diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 2df5e69998..53618d4628 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -250,8 +250,9 @@ $nl { $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 } @@ -377,10 +378,13 @@ HELP: equal? } $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" } @@ -665,6 +669,11 @@ HELP: bi@ "[ p ] bi@" ">r p r> p" } + "The following two lines are also equivalent:" + { $code + "[ p ] bi@" + "[ p ] [ p ] bi*" + } } ; HELP: 2bi@ @@ -676,6 +685,11 @@ HELP: 2bi@ "[ p ] 2bi@" ">r >r p r> r> p" } + "The following two lines are also equivalent:" + { $code + "[ p ] 2bi@" + "[ p ] [ p ] 2bi*" + } } ; HELP: tri@ @@ -687,6 +701,11 @@ HELP: tri@ "[ 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 -- ) @@ -785,19 +804,6 @@ HELP: null "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" } "." } ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index ae775ec116..1935c89431 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel.private slots.private ; +USING: kernel.private slots.private classes.tuple.private ; IN: kernel ! Stack stuff @@ -114,12 +114,6 @@ DEFER: if [ 2nip call ] if ; inline ! Object protocol -GENERIC: delegate ( obj -- delegate ) - -M: object delegate drop f ; - -GENERIC: set-delegate ( delegate tuple -- ) - GENERIC: hashcode* ( depth obj -- code ) M: object hashcode* 2drop 0 ; @@ -130,6 +124,10 @@ 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 @@ -142,18 +140,11 @@ M: object clone ; M: callstack clone (clone) ; ! Tuple construction -GENERIC# get-slots 1 ( tuple slots -- ... ) +: construct-empty ( class -- tuple ) + tuple-layout ; -GENERIC# set-slots 1 ( ... tuple slots -- ) - -GENERIC: construct-empty ( class -- tuple ) - -GENERIC: construct ( ... slots class -- tuple ) inline - -GENERIC: construct-boa ( ... class -- tuple ) - -: construct-delegate ( delegate class -- tuple ) - >r { set-delegate } r> construct ; inline +: construct-boa ( ... class -- tuple ) + tuple-layout ; ! Quotation building : 2curry ( obj1 obj2 quot -- curry ) @@ -201,3 +192,20 @@ GENERIC: construct-boa ( ... class -- tuple ) : do-primitive ( number -- ) "Improper primitive call" throw ; PRIVATE> + +! Deprecated +GENERIC: delegate ( obj -- delegate ) + +M: object delegate drop f ; + +GENERIC: set-delegate ( delegate tuple -- ) + +GENERIC# get-slots 1 ( tuple slots -- ... ) + +GENERIC# set-slots 1 ( ... tuple slots -- ) + +: construct ( ... slots class -- tuple ) + construct-empty [ swap set-slots ] keep ; inline + +: construct-delegate ( delegate class -- tuple ) + >r { set-delegate } r> construct ; inline diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index c108e3b1a7..11228c879a 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -154,7 +154,7 @@ SYMBOL: potential-loops ] [ 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 ] } } cond diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 1f3df92421..81f53b5ace 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -70,12 +70,20 @@ DEFER: (flat-length) ] if ; ! Partial dispatch of math-generic words +: normalize-math-class ( class -- class' ) + { fixnum bignum ratio float complex } + [ class< ] with find nip object or ; + : 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 ; + over node-input-classes + [ first normalize-math-class ] + [ second normalize-math-class ] bi + 3dup math-both-known? + [ math-method f splice-quot ] + [ 2drop 2drop t ] if ; : inline-method ( #call -- node ) dup node-param { diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index a4782078ee..2bce2dc94c 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -75,7 +75,7 @@ sequences.private combinators ; 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 diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index abe48ec272..4ec4bfeb36 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -269,7 +269,7 @@ generic.standard system ; : 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 diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 58c68a3614..2a481d413d 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -365,7 +365,17 @@ ERROR: bad-number ; : (:) 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? diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 27b63ec26f..0f384b159d 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -57,8 +57,6 @@ unit-test [ ] [ \ integer see ] unit-test -[ ] [ \ general-t see ] unit-test - [ ] [ \ generic see ] unit-test [ ] [ \ duplex-stream see ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index ca46066861..01a1cb9b6a 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -416,6 +416,9 @@ PRIVATE> 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 ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index bd349953df..b242e65de5 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -243,7 +243,7 @@ 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" } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 19fdf0e45f..df135d0c1c 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -185,4 +185,10 @@ IN: bootstrap.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 diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index a6a5a014a7..8ef5f6f508 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -6,13 +6,11 @@ IN: vocabs SYMBOL: dictionary -TUPLE: vocab +TUPLE: vocab < identity-tuple name words main help source-loaded? docs-loaded? ; -M: vocab equal? 2drop f ; - : ( name -- vocab ) H{ } clone { set-vocab-name set-vocab-words } @@ -92,10 +90,6 @@ TUPLE: vocab-link name ; : ( name -- vocab-link ) vocab-link construct-boa ; -M: vocab-link equal? - over vocab-link? - [ [ vocab-link-name ] bi@ = ] [ 2drop f ] if ; - M: vocab-link hashcode* vocab-link-name hashcode* ; diff --git a/core/words/words.factor b/core/words/words.factor index a45e1627e9..1232a97ddc 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -173,7 +173,7 @@ GENERIC: subwords ( word -- seq ) 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 ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 79382091ab..20c5bb92c9 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -6,7 +6,7 @@ init threads continuations math io.encodings io.streams.duplex io.nonblocking accessors ; IN: io.launcher -TUPLE: process +TUPLE: process < identity-tuple command detached @@ -65,8 +65,6 @@ M: object register-process drop ; V{ } clone over processes get set-at register-process ; -M: process equal? 2drop f ; - M: process hashcode* process-handle hashcode* ; : pass-environment? ( process -- ? ) diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor index 8480fcd856..74a84c48ff 100755 --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -96,14 +96,13 @@ M: inet6 parse-sockaddr 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 diff --git a/extra/models/models.factor b/extra/models/models.factor index fd84dd248f..ffb9b1127a 100755 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -4,13 +4,12 @@ USING: generic kernel math sequences arrays assocs alarms calendar ; IN: models -TUPLE: model value connections dependencies ref locked? ; +TUPLE: model < identity-tuple +value connections dependencies ref locked? ; : ( value -- model ) V{ } clone V{ } clone 0 f model construct-boa ; -M: model equal? 2drop f ; - M: model hashcode* drop model hashcode* ; : add-dependency ( dep model -- ) diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 1963f5670a..1c83bc9713 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -27,9 +27,8 @@ DEFER: freetype \ 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* ; diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index ddcaa4b979..c4f11f2e87 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -44,14 +44,12 @@ M: array rect-dim drop { 0 0 } ; : rect-union ( rect1 rect2 -- newrect ) (rect-union) ; -TUPLE: gadget +TUPLE: gadget < identity-tuple pref-dim parent children orientation focus 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 ; @@ -354,7 +352,7 @@ SYMBOL: in-layout? 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 @@ -401,7 +399,7 @@ M: f request-focus-on 2drop ; dup focusable-child swap request-focus-on ; : focus-path ( world -- seq ) - [ dup ] [ [ gadget-focus ] keep ] [ ] unfold nip ; + [ gadget-parent ] follow ; : make-gadget ( quot gadget -- gadget ) [ \ make-gadget rot with-variable ] keep ; inline diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor index a44b553858..8ee64b58be 100755 --- a/extra/ui/gadgets/worlds/worlds.factor +++ b/extra/ui/gadgets/worlds/worlds.factor @@ -5,7 +5,7 @@ namespaces opengl sequences io combinators math.vectors ui.gadgets ui.gestures ui.render ui.backend inspector ; IN: ui.gadgets.worlds -TUPLE: world +TUPLE: world < identity-tuple active? focused? glass title status @@ -46,8 +46,6 @@ M: world request-focus-on ( child gadget -- ) t over set-gadget-root? dup request-focus ; -M: world equal? 2drop f ; - M: world hashcode* drop world hashcode* ; M: world pref-dim* From 337d582a811ee6c3276942acf668eb0c5be15733 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 21:31:41 -0500 Subject: [PATCH 411/886] Fix call-next-method --- core/generic/standard/standard.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 2b2dbd2b2d..c36e5f1921 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -135,6 +135,7 @@ M: standard-generic next-method-quot ] [ [ inconsistent-next-method ] 2curry , ] 2tri + \ if , ] [ ] make ; TUPLE: hook-combination var ; From a27fa2909875b302191d8c48a073b1ead0875ccc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 21:37:26 -0500 Subject: [PATCH 412/886] Remove type, class-hash primitives --- core/bootstrap/primitives.factor | 2 -- core/inference/known-words/known-words.factor | 3 --- vm/primitives.c | 2 -- vm/run.c | 21 ------------------- vm/run.h | 2 -- 5 files changed, 30 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index f3846de5b1..6c87730278 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -656,7 +656,6 @@ define-builtin { "code-room" "memory" } { "os-env" "system" } { "millis" "system" } - { "type" "kernel.private" } { "tag" "kernel.private" } { "modify-code-heap" "compiler.units" } { "dlopen" "alien" } @@ -728,7 +727,6 @@ define-builtin { "(sleep)" "threads.private" } { "" "float-arrays" } { "" "classes.tuple.private" } - { "class-hash" "kernel.private" } { "callstack>array" "kernel" } { "innermost-frame-quot" "kernel.private" } { "innermost-frame-scan" "kernel.private" } diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 3cc78831a3..5092b86a4d 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -386,9 +386,6 @@ set-primitive-effect \ tag { object } { fixnum } set-primitive-effect \ tag make-foldable -\ class-hash { object } { fixnum } set-primitive-effect -\ class-hash make-foldable - \ cwd { } { string } set-primitive-effect \ cd { string } { } set-primitive-effect diff --git a/vm/primitives.c b/vm/primitives.c index 203ebb7f6b..6a6aeb9d46 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -106,7 +106,6 @@ void *primitives[] = { primitive_code_room, primitive_os_env, primitive_millis, - primitive_type, primitive_tag, primitive_modify_code_heap, primitive_dlopen, @@ -178,7 +177,6 @@ void *primitives[] = { 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, diff --git a/vm/run.c b/vm/run.c index cec19b5445..282be0a447 100755 --- a/vm/run.c +++ b/vm/run.c @@ -307,32 +307,11 @@ DEFINE_PRIMITIVE(sleep) 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_TUPLE *tuple = untag_object(obj); - F_TUPLE_LAYOUT *layout = untag_object(tuple->layout); - drepl(layout->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()); diff --git a/vm/run.h b/vm/run.h index 216a00b27d..c112c5f587 100755 --- a/vm/run.h +++ b/vm/run.h @@ -253,9 +253,7 @@ 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); From 50d8b351de04895ed22b5b2ff4720b9f5bfe28b0 Mon Sep 17 00:00:00 2001 From: erg Date: Wed, 2 Apr 2008 21:43:17 -0500 Subject: [PATCH 413/886] fix using --- extra/openal/macosx/macosx.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/openal/macosx/macosx.factor b/extra/openal/macosx/macosx.factor index c03ad5693c..d2a0422d8d 100644 --- a/extra/openal/macosx/macosx.factor +++ b/extra/openal/macosx/macosx.factor @@ -1,7 +1,7 @@ ! 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 ; +combinators.lib openal.backend namespaces system ; IN: openal.macosx LIBRARY: alut From 27f2992dc5eca644fb077017746243b5f34e4cf2 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 3 Apr 2008 16:09:03 +1300 Subject: [PATCH 414/886] Add failing ebnf test --- extra/peg/ebnf/ebnf-tests.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 84c492c55a..0879ecda49 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel tools.test peg peg.ebnf words math math.parser ; +USING: kernel tools.test peg peg.ebnf words math math.parser sequences ; IN: peg.ebnf.tests { T{ ebnf-non-terminal f "abc" } } [ @@ -247,6 +247,10 @@ IN: peg.ebnf.tests "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 From cc7d945a80273d4ce966d307424a4f66e72e32ae Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 3 Apr 2008 17:28:09 +1300 Subject: [PATCH 415/886] Change ebnf variables to not use namespaces --- extra/peg/ebnf/ebnf.factor | 55 +++++++++++++++++++++++++------------- 1 file changed, 37 insertions(+), 18 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index b0dfaad5b3..49c2d5a8dd 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -237,17 +237,16 @@ GENERIC: (transform) ( ast -- parser ) SYMBOL: parser SYMBOL: main -SYMBOL: vars : transform ( ast -- object ) - H{ } clone dup dup [ parser set V{ } vars set swap (transform) main set ] bind ; + H{ } clone dup dup [ parser set swap (transform) main set ] bind ; M: ebnf (transform) ( ast -- parser ) rules>> [ (transform) ] map peek ; M: ebnf-rule (transform) ( ast -- parser ) dup elements>> - vars get clone vars [ (transform) ] with-variable [ + (transform) [ swap symbol>> set ] keep ; @@ -282,30 +281,50 @@ M: ebnf-repeat1 (transform) ( ast -- parser ) M: ebnf-optional (transform) ( ast -- parser ) transform-group optional ; -: build-locals ( string vars -- string ) - dup empty? [ - drop - ] [ +GENERIC: build-locals ( code ast -- code ) + +M: ebnf-sequence build-locals ( code ast -- code ) + elements>> dup [ ebnf-var? ] subset empty? [ + drop + ] [ [ - "USING: locals namespaces ; [let* | " % - [ dup % " [ \"" % % "\" get ] " % ] each - " | " % - % - " ] with-locals" % + "USING: locals sequences ; [let* | " % + dup length swap [ + dup ebnf-var? [ + name>> % + " [ " % # " over nth ] " % + ] [ + 2drop + ] if + ] 2each + " | " % + % + " ] with-locals" % ] "" make ] if ; +M: ebnf-var build-locals ( code ast -- ) + [ + "USING: locals kernel ; [let* | " % + name>> % " [ dup ] " % + " | " % + % + " ] with-locals" % + ] "" make ; + +M: object build-locals ( code ast -- ) + drop ; + M: ebnf-action (transform) ( ast -- parser ) - [ parser>> (transform) ] keep - code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit action ; + [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals + string-lines [ parse-lines ] with-compilation-unit action ; M: ebnf-semantic (transform) ( ast -- parser ) - [ parser>> (transform) ] keep - code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit semantic ; + [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals + string-lines [ parse-lines ] with-compilation-unit semantic ; M: ebnf-var (transform) ( ast -- parser ) - [ parser>> (transform) ] [ name>> ] bi - dup vars get push [ dupd set ] curry action ; + parser>> (transform) ; M: ebnf-terminal (transform) ( ast -- parser ) symbol>> token ; From 970f0055c266ab813c177b4c4f545e51ea203479 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 3 Apr 2008 17:33:37 +1300 Subject: [PATCH 416/886] Fix failing ebnf unit test --- extra/peg/ebnf/ebnf.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 49c2d5a8dd..e5787e6cf8 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -213,6 +213,7 @@ DEFER: 'choice' : 'actioned-sequence' ( -- parser ) [ [ 'sequence' , "=>" syntax , 'action' , ] seq* [ first2 ] action , + [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , "=>" syntax , 'action' , ] seq* [ first3 >r r> ] action , [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 ] action , 'sequence' , ] choice* ; From 93d9722a6bb3bc9c956f10475febcbe85ddf61fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 00:21:53 -0500 Subject: [PATCH 417/886] Fix class resetting --- core/classes/mixin/mixin.factor | 2 +- core/classes/predicate/predicate.factor | 5 ++++- core/classes/tuple/tuple.factor | 1 + core/classes/union/union.factor | 2 +- core/parser/parser.factor | 13 ++++++++----- 5 files changed, 15 insertions(+), 8 deletions(-) diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index b771aa8920..aefd522269 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -7,7 +7,7 @@ IN: classes.mixin 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 diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index 0f98f1f5c4..4729a6dd5e 100755 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -25,5 +25,8 @@ PREDICATE: predicate-class < class M: predicate-class reset-class { - "metaclass" "predicate-definition" "superclass" + "class" + "metaclass" + "predicate-definition" + "superclass" } reset-props ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index ac1a7b8849..58c6f2c581 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -212,6 +212,7 @@ M: tuple-class reset-class ] with each ] [ { + "class" "metaclass" "superclass" "layout" diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 9079974a60..09f8f88ced 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -29,4 +29,4 @@ M: union-class update-class define-union-predicate ; 2bi ; M: union-class reset-class - { "metaclass" "members" } reset-props ; + { "class" "metaclass" "members" } reset-props ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 2a481d413d..5551ac8af0 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -505,8 +505,10 @@ SYMBOL: interactive-vocabs : 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 + [ diff values [ [ reset-generic ] [ define-symbol ] bi ] each ] + [ swap diff values [ class? ] subset [ reset-class ] each ] + 2bi ; : forget-smudged ( -- ) smudged-usage forget-all @@ -515,9 +517,10 @@ SYMBOL: interactive-vocabs : 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 ) [ From cfe1c5d39e95f111f98a72faa2936fa577219fda Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 00:22:10 -0500 Subject: [PATCH 418/886] Update unit test for word removal --- core/compiler/tests/templates.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index a82208e9b9..565c045e2a 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -172,14 +172,14 @@ TUPLE: my-tuple ; [ 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 From 0cf667859af5a6cb823127539303d3e56e5c371c Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 00:59:20 -0500 Subject: [PATCH 419/886] fix random on openbsd --- extra/random/unix/unix.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor index 3be2697bdf..6a72baa21b 100644 --- a/extra/random/unix/unix.factor +++ b/extra/random/unix/unix.factor @@ -15,7 +15,7 @@ C: unix-random M: unix-random random-bytes* ( n tuple -- byte-array ) path>> file-read-unbuffered ; -os "openbsd" = [ +os openbsd? [ [ "/dev/srandom" secure-random-generator set-global "/dev/prandom" insecure-random-generator set-global From e490e9b636dc045d53935c1ac86346af68650ae8 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 01:48:29 -0500 Subject: [PATCH 420/886] refactor hardware-info a bit --- extra/hardware-info/backend/backend.factor | 3 +-- extra/hardware-info/hardware-info.factor | 15 ++++++++---- extra/hardware-info/macosx/macosx.factor | 28 ++++++++++++---------- extra/hardware-info/windows/ce/ce.factor | 19 +++++++-------- extra/hardware-info/windows/nt/nt.factor | 21 +++++++--------- 5 files changed, 44 insertions(+), 42 deletions(-) diff --git a/extra/hardware-info/backend/backend.factor b/extra/hardware-info/backend/backend.factor index 17794c196d..95a56da2d2 100644 --- a/extra/hardware-info/backend/backend.factor +++ b/extra/hardware-info/backend/backend.factor @@ -1,8 +1,7 @@ +USING: system ; IN: hardware-info.backend -SYMBOL: os HOOK: cpus os ( -- n ) - HOOK: memory-load os ( -- n ) HOOK: physical-mem os ( -- n ) HOOK: available-mem os ( -- n ) diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor index ecdcc42cb5..6d27cf5252 100755 --- a/extra/hardware-info/hardware-info.factor +++ b/extra/hardware-info/hardware-info.factor @@ -1,10 +1,13 @@ -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^ /i number>string write bl ] [ write ] bi* ; + +: kb ( x -- ) 10 "kB" write-unit ; +: megs ( x -- ) 20 "MB" write-unit ; +: gigs ( x -- ) 30 "GB" write-unit ; << { { [ os windows? ] [ "hardware-info.windows" ] } @@ -12,3 +15,7 @@ IN: hardware-info { [ os macosx? ] [ "hardware-info.macosx" ] } { [ t ] [ f ] } } cond [ require ] when* >> + +: hardware-report. ( -- ) + "CPUs: " write cpus number>string write nl + "Physical RAM: " write physical-mem megs nl ; diff --git a/extra/hardware-info/macosx/macosx.factor b/extra/hardware-info/macosx/macosx.factor index c246a95186..dac052a1de 100644 --- a/extra/hardware-info/macosx/macosx.factor +++ b/extra/hardware-info/macosx/macosx.factor @@ -1,10 +1,8 @@ USING: alien alien.c-types alien.syntax byte-arrays kernel -namespaces sequences unix hardware-info.backend ; +namespaces sequences unix hardware-info.backend system +io.unix.backend ; IN: hardware-info.macosx -TUPLE: macosx ; -T{ macosx } os set-global - ! See /usr/include/sys/sysctl.h for constants LIBRARY: libc @@ -14,14 +12,11 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi [ ] 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> - [ ] keep - (sysctl-query) [ throw ] when* ; + >r [ make-int-array ] [ length ] bi r> + [ ] [ ] bi (sysctl-query) ; : sysctl-query-string ( seq -- n ) 4096 sysctl-query alien>char-string ; @@ -36,8 +31,15 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi : 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 ; : cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ; @@ -47,7 +49,7 @@ M: macosx cpus ( -- n ) { 6 3 } 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 ; diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor index f671ea9426..55c2ac6c0d 100755 --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/hardware-info/windows/ce/ce.factor @@ -2,33 +2,30 @@ USING: alien.c-types hardware-info kernel math namespaces windows windows.kernel32 hardware-info.backend ; IN: hardware-info.windows.ce -TUPLE: wince-os ; -T{ wince-os } os set-global - : memory-status ( -- MEMORYSTATUS ) "MEMORYSTATUS" "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 ; diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor index 8bdb75fe6a..ba9c1d74b5 100755 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -1,15 +1,12 @@ USING: alien alien.c-types 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" [ GetSystemInfo ] keep ; -M: winnt-os cpus ( -- n ) +M: winnt cpus ( -- n ) system-info SYSTEM_INFO-dwNumberOfProcessors ; : memory-status ( -- MEMORYSTATUSEX ) @@ -17,25 +14,25 @@ M: winnt-os cpus ( -- n ) "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 ; : computer-name ( -- string ) From 54265a9f4c33d2f60cf87320fe4ec530dc9a0255 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 04:58:37 -0500 Subject: [PATCH 421/886] Final inheritance fixes --- core/classes/tuple/tuple-tests.factor | 11 +++ core/generic/standard/standard-tests.factor | 98 ++++++++++++++++++++- core/inference/class/class-tests.factor | 14 +++ core/inference/class/class.factor | 31 ++++--- core/optimizer/inlining/inlining.factor | 9 +- core/parser/parser.factor | 22 +++-- 6 files changed, 159 insertions(+), 26 deletions(-) diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 735f328a67..a8e9066f56 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -542,3 +542,14 @@ USE: vocabs [ 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" + + "another-forget-accessors-test" parse-stream +] unit-test + +[ t ] [ \ another-forget-accessors-test class? ] unit-test diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index fbca22471c..2f58770b1a 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -1,7 +1,7 @@ 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 ; +words float-arrays byte-arrays bit-arrays parser namespaces ; GENERIC: lo-tag-test @@ -137,3 +137,99 @@ 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 construct-boa salary ] unit-test + +[ 24000 ] [ tape-monkey construct-boa salary ] unit-test + +[ 36000 ] [ junior-manager construct-boa salary ] unit-test + +[ 41000 ] [ middle-manager construct-boa salary ] unit-test + +[ 51000 ] [ senior-manager construct-boa salary ] unit-test + +[ 102000 ] [ executive construct-boa salary ] unit-test + +[ ceo construct-boa salary ] +[ T{ inconsistent-next-method f 5 ceo salary } = ] must-fail-with + +[ intern construct-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 diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index b54dbe256a..038ab1d230 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -233,6 +233,20 @@ M: fixnum annotate-entry-test-1 drop ; \ >float inlined? ] unit-test +GENERIC: detect-float ( a -- b ) + +M: float detect-float ; + +[ t ] [ + [ { 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 diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 8269952409..033d2cce7a 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -274,7 +274,7 @@ DEFER: (infer-classes) (merge-intervals) 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? [ @@ -290,28 +290,31 @@ DEFER: (infer-classes) 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 ; + [ 1array ] keep annotate-entry ; 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 suffix - pick annotate-entry - node-child (infer-classes) ; + { + [ annotate-node ] + [ infer-classes-before ] + [ infer-children ] + [ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ] + [ node-child (infer-classes) ] + } cleave ; 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 (infer-classes) ] bi ] when* ; : infer-classes-with ( node classes literals intervals -- ) diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 81f53b5ace..9d41d6eae1 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -71,8 +71,13 @@ DEFER: (flat-length) ! Partial dispatch of math-generic words : normalize-math-class ( class -- class' ) - { fixnum bignum ratio float complex } - [ class< ] with find nip object or ; + { + fixnum bignum integer + ratio rational + float real + complex number + object + } [ class< ] with find nip ; : math-both-known? ( word left right -- ? ) math-class-max swap specific-method ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 5551ac8af0..902bae29b5 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -477,18 +477,22 @@ SYMBOL: interactive-vocabs nl ] when 2drop ; -: filter-moved ( assoc -- newassoc ) - [ +: filter-moved ( assoc1 assoc2 -- seq ) + 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 ] bi@ diff ; + [ get first2 union ] bi@ ; + +: removed-classes ( -- assoc1 assoc2 ) + new-definitions old-definitions + [ get second ] bi@ ; : smudged-usage ( -- usages referenced removed ) - removed-definitions filter-moved keys [ + removed-definitions filter-moved [ outside-usages [ empty? [ drop f ] [ @@ -506,9 +510,9 @@ SYMBOL: interactive-vocabs #! If a class word had a compound definition which was #! removed, it must go back to being a symbol. new-definitions get first2 - [ diff values [ [ reset-generic ] [ define-symbol ] bi ] each ] - [ swap diff values [ class? ] subset [ reset-class ] each ] - 2bi ; + filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each + removed-classes + filter-moved [ class? ] subset [ reset-class ] each ; : forget-smudged ( -- ) smudged-usage forget-all From 45cf030cbd6ed1075e626028849457969c955ef7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 05:21:45 -0500 Subject: [PATCH 422/886] Use call-next-method --- extra/smtp/smtp-tests.factor | 6 ++++++ extra/smtp/smtp.factor | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index a705a9609e..1d22ed731a 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -3,6 +3,12 @@ smtp.server kernel sequences namespaces logging accessors assocs sorting ; IN: smtp.tests +[ t ] [ + + 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 diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 13db422621..ee2b021329 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -106,7 +106,7 @@ LOG: smtp-response DEBUG TUPLE: email from to subject headers body ; M: email clone - (clone) [ clone ] change-headers ; + call-next-method [ clone ] change-headers ; : (send) ( email -- ) [ From 1ff2eaf09c9da714cd4699cddf07fba863934abf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 05:24:04 -0500 Subject: [PATCH 423/886] Move enum docs --- core/assocs/assocs-docs.factor | 14 ++++++++++++++ core/mirrors/mirrors-docs.factor | 8 -------- extra/help/handbook/handbook.factor | 1 + 3 files changed, 15 insertions(+), 8 deletions(-) diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index b6326e1c10..9b0922d096 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -16,6 +16,20 @@ $nl "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 } ; + +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: +{ $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 } diff --git a/core/mirrors/mirrors-docs.factor b/core/mirrors/mirrors-docs.factor index 725a757e61..dc4315fb39 100755 --- a/core/mirrors/mirrors-docs.factor +++ b/core/mirrors/mirrors-docs.factor @@ -7,9 +7,6 @@ $nl "A mirror provides such a view of a tuple:" { $subsection mirror } { $subsection } -"An enum provides such a view of a sequence:" -{ $subsection enum } -{ $subsection } "Utility word used by developer tools which inspect objects:" { $subsection make-mirror } { $see-also "slots" } ; @@ -44,11 +41,6 @@ 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." } ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index e45c49aa25..847a5952af 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -152,6 +152,7 @@ ARTICLE: "collections" "Collections" "Implementations:" { $subsection "hashtables" } { $subsection "alists" } +{ $subsection "enums" } { $heading "Other collections" } { $subsection "boxes" } { $subsection "dlists" } From 88092f2c2ae7c86c3c831f8aaaea98e31933fa8a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 05:27:38 -0500 Subject: [PATCH 424/886] Documentation update --- core/assocs/assocs-docs.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 9b0922d096..e85789a4f2 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -19,7 +19,9 @@ $nl ARTICLE: "enums" "Enumerations" "An enumeration provides a view of a sequence as an assoc mapping integer indices to elements:" { $subsection enum } -{ $subsection } ; +{ $subsection } +"Inverting a permutation using enumerations:" +{ $example "USING: assocs sorting prettyprint ;" ": invert >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." From 16377be935bcfb1a9346d8d78c22f486baeac2a1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 05:57:20 -0500 Subject: [PATCH 425/886] Use call-next-method --- core/classes/tuple/tuple.factor | 4 ++-- core/generic/generic.factor | 21 ++++++++------------- core/words/words-docs.factor | 6 +----- core/words/words.factor | 8 +------- 4 files changed, 12 insertions(+), 27 deletions(-) diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 58c6f2c581..b1cb3f8a66 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -207,8 +207,8 @@ M: tuple-class define-tuple-class M: tuple-class reset-class [ dup "slot-names" word-prop [ - [ reader-word forget-method ] - [ writer-word forget-method ] 2bi + [ reader-word method forget ] + [ writer-word method forget ] 2bi ] with each ] [ { diff --git a/core/generic/generic.factor b/core/generic/generic.factor index b0099f770c..72948c5473 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -106,14 +106,6 @@ M: method-spec definer 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* ; @@ -123,9 +115,12 @@ M: method-body definer M: method-body forget* dup "forgotten" word-prop [ drop ] [ [ - [ "method-class" word-prop ] + [ "method-class" word-prop ] [ "method-generic" word-prop ] bi - forget-method + dup generic? [ + [ delete-at* ] with-methods + [ call-next-method ] [ drop ] if + ] [ 2drop ] if ] [ t "forgotten" set-word-prop ] bi ] if ; @@ -145,7 +140,7 @@ M: method-body forget* M: class forget* ( class -- ) [ forget-methods ] [ update-map- ] - [ forget-word ] + [ call-next-method ] tri ; M: assoc update-methods ( assoc -- ) @@ -169,8 +164,8 @@ M: generic subwords tri ] { } make ; -M: generic forget-word - [ subwords forget-all ] [ (forget-word) ] bi ; +M: generic forget* + [ subwords forget-all ] [ call-next-method ] bi ; : xref-generics ( -- ) all-words [ subwords [ xref ] each ] each ; diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index eb1bd0908a..a715aab64f 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -324,11 +324,7 @@ HELP: constructor-word { $description "Creates a new word, surrounding " { $snippet "name" } " in angle brackets." } { $examples { $example "USING: prettyprint words ;" "\"salmon\" \"scratchpad\" constructor-word ." "" } } ; -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 } } diff --git a/core/words/words.factor b/core/words/words.factor index 1232a97ddc..059815e952 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -212,9 +212,7 @@ M: word where "loc" word-prop ; 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 @@ -222,10 +220,6 @@ GENERIC: forget-word ( word -- ) 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 ; From b096395e6c1486a8de01b2d9f8a92dca32e00501 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 06:11:18 -0500 Subject: [PATCH 426/886] Fix reports.noise load error --- extra/reports/noise/noise.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 7e9496c90d..6921d1223a 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -136,7 +136,7 @@ M: lambda-word word-noise-factor : flatten-generics ( words -- words' ) [ - dup generic? [ methods values ] [ 1array ] if + dup generic? [ "methods" word-prop values ] [ 1array ] if ] map concat ; : noisy-words ( -- alist ) From d642347f341e3820a3167e1c9c7e489d42928858 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 11:55:08 -0500 Subject: [PATCH 427/886] move bit twiddling words to math.bitfields.lib use 32-bit in mersenne-twister --- extra/crypto/common/common-docs.factor | 17 ------------- extra/crypto/common/common.factor | 24 ++----------------- extra/crypto/sha1/sha1.factor | 4 ++-- extra/crypto/sha2/sha2.factor | 20 ++++++++-------- extra/math/functions/functions.factor | 9 ------- .../mersenne-twister/mersenne-twister.factor | 13 ++++------ 6 files changed, 19 insertions(+), 68 deletions(-) diff --git a/extra/crypto/common/common-docs.factor b/extra/crypto/common/common-docs.factor index b53ecaac3c..559c7934d0 100644 --- a/extra/crypto/common/common-docs.factor +++ b/extra/crypto/common/common-docs.factor @@ -2,23 +2,6 @@ USING: help.markup help.syntax kernel math sequences quotations 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." } diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor index 3ac551d114..f0129772b0 100644 --- a/extra/crypto/common/common.factor +++ b/extra/crypto/common/common.factor @@ -1,11 +1,8 @@ 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-bit ; inline : (nth-int) ( string n -- int ) 2 shift dup 4 + rot ; inline @@ -39,26 +36,9 @@ SYMBOL: big-endian? 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 ; diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index 8f3d3e6ecc..7e8677a117 100755 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -1,7 +1,7 @@ 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. @@ -66,7 +66,7 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; K get nth , A get 5 bitroll-32 , E get , - ] { } make sum >32-bit ; inline + ] { } make sum 32-bit ; inline : set-vars ( temp -- ) ! E = D; D = C; C = S^30(B); B = A; A = TEMP; diff --git a/extra/crypto/sha2/sha2.factor b/extra/crypto/sha2/sha2.factor index daba6d29ff..f555de8b08 100755 --- a/extra/crypto/sha2/sha2.factor +++ b/extra/crypto/sha2/sha2.factor @@ -1,19 +1,19 @@ USING: crypto.common kernel splitting math sequences namespaces -io.binary symbols ; +io.binary symbols math.bitfields.lib ; IN: crypto.sha2 word ; -: 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 ) { @@ -124,7 +124,7 @@ PRIVATE> initial-H-256 H set 4 word-size set 64 block-size set - \ >32-bit >word set + \ 32-bit >word set byte-array>sha2 ] with-scope ; diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor index dcbccb4316..77c7d9247d 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -30,15 +30,6 @@ M: real sqrt 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 ) diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index 77054ea377..2aa6f45897 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -4,7 +4,7 @@ ! 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 ; +accessors math.ranges random circular math.bitfields.lib ; IN: random.mersenne-twister r mt-n r> seq>> [ [ (mt-generate) ] keep set-generated ] curry each ] [ 0 >>i drop ] bi ; -: init-mt-first ( seed -- seq ) - >r mt-n 0 r> - HEX: ffffffff bitand 0 pick set-nth ; - : init-mt-formula ( seq i -- f(seq[i]) ) tuck swap nth dup -30 shift bitxor 1812433253 * + - 1+ HEX: ffffffff bitand ; + 1+ 32-bit ; : init-mt-rest ( seq -- ) - mt-n 1- [0,b) [ + mt-n 1- [ dupd [ init-mt-formula ] keep 1+ rot set-nth ] with each ; : init-mt-seq ( seed -- seq ) - init-mt-first dup init-mt-rest ; + 32-bit mt-n 0 + [ set-first ] [ init-mt-rest ] [ ] tri ; : mt-temper ( y -- yt ) dup -11 shift bitxor From 5c2b2b024e1c0b6a4332d752d68f119048b56d4a Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 13:04:24 -0500 Subject: [PATCH 428/886] more cleanup of mersenne-twister -- you can actually understand it now :) --- .../mersenne-twister/mersenne-twister.factor | 55 ++++++++++--------- 1 file changed, 29 insertions(+), 26 deletions(-) diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index 2aa6f45897..d3a5fad4ca 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -2,9 +2,9 @@ ! 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 ; +accessors math.ranges random circular math.bitfields.lib +combinators ; IN: random.mersenne-twister r >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi - r> bitxor bitxor r> r> set-nth ; inline : calculate-y ( y1 y2 mt -- y ) - tuck [ nth mt-hi ] [ nth mt-lo ] 2bi* bitor ; inline + tuck + [ nth 32 mask-bit ] + [ nth 31 bits ] 2bi* bitor ; inline -: (mt-generate) ( n mt-seq -- y to from-elt ) - [ >r dup 1+ r> calculate-y ] - [ >r mt-m + r> nth ] - [ drop ] 2tri ; +: (mt-generate) ( n mt-seq -- next-mt ) + [ + [ dup 1+ ] [ calculate-y ] bi* + [ 2/ ] [ odd? mt-a 0 ? ] bi bitxor + ] [ + [ mt-m + ] [ nth ] bi* + ] 2bi bitxor ; : mt-generate ( mt -- ) - [ >r mt-n r> seq>> [ [ (mt-generate) ] keep set-generated ] curry each ] - [ 0 >>i drop ] bi ; + [ + mt-n swap seq>> [ + [ (mt-generate) ] [ set-nth ] 2bi + ] curry each + ] [ 0 >>i drop ] bi ; -: init-mt-formula ( seq i -- f(seq[i]) ) - tuck swap nth dup -30 shift bitxor 1812433253 * + - 1+ 32-bit ; +: 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- [ - dupd [ init-mt-formula ] keep 1+ rot set-nth - ] with each ; + mt-n 1- swap [ + [ init-mt-formula ] [ >r 1+ r> set-nth ] 2bi + ] curry each ; : init-mt-seq ( seed -- seq ) - 32-bit mt-n 0 + 32 bits mt-n 0 [ set-first ] [ init-mt-rest ] [ ] tri ; : mt-temper ( y -- yt ) @@ -52,6 +53,9 @@ TUPLE: mersenne-twister seq i ; 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> : ( seed -- obj ) @@ -62,7 +66,6 @@ M: mersenne-twister seed-random ( mt seed -- ) init-mt-seq >>seq drop ; M: mersenne-twister random-32* ( mt -- r ) - dup [ i>> ] [ seq>> ] bi - over mt-n < [ nip >r dup mt-generate 0 r> ] unless - nth mt-temper - swap [ 1+ ] change-i drop ; + [ next-index ] + [ seq>> nth mt-temper ] + [ [ 1+ ] change-i drop ] tri ; From 0b90458cca9e82e2e1174edc81324f6e6e29c519 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 13:27:10 -0500 Subject: [PATCH 429/886] simplify bitroll --- extra/crypto/common/common.factor | 2 +- extra/crypto/sha1/sha1.factor | 2 +- extra/crypto/sha2/sha2.factor | 3 +-- extra/math/bitfields/lib/lib-docs.factor | 16 ++++++++++++ extra/math/bitfields/lib/lib-tests.factor | 14 ++++++++++ extra/math/bitfields/lib/lib.factor | 31 +++++++++++++++++++++++ 6 files changed, 64 insertions(+), 4 deletions(-) create mode 100644 extra/math/bitfields/lib/lib-docs.factor create mode 100644 extra/math/bitfields/lib/lib-tests.factor create mode 100644 extra/math/bitfields/lib/lib.factor diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor index f0129772b0..b9f1d43784 100644 --- a/extra/crypto/common/common.factor +++ b/extra/crypto/common/common.factor @@ -2,7 +2,7 @@ USING: arrays kernel io io.binary sbufs splitting strings sequences namespaces math math.parser parser hints math.bitfields.lib ; IN: crypto.common -: w+ ( int int -- int ) + 32-bit ; inline +: w+ ( int int -- int ) + 32 bits ; inline : (nth-int) ( string n -- int ) 2 shift dup 4 + rot ; inline diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index 7e8677a117..d054eda31b 100755 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -66,7 +66,7 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; 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; diff --git a/extra/crypto/sha2/sha2.factor b/extra/crypto/sha2/sha2.factor index f555de8b08..0acc5c1388 100755 --- a/extra/crypto/sha2/sha2.factor +++ b/extra/crypto/sha2/sha2.factor @@ -4,7 +4,7 @@ IN: crypto.sha2 word ; +SYMBOLS: vars M K H S0 S1 process-M word-size block-size ; : a 0 ; inline : b 1 ; inline @@ -124,7 +124,6 @@ PRIVATE> initial-H-256 H set 4 word-size set 64 block-size set - \ 32-bit >word set byte-array>sha2 ] with-scope ; diff --git a/extra/math/bitfields/lib/lib-docs.factor b/extra/math/bitfields/lib/lib-docs.factor new file mode 100644 index 0000000000..bfbe9eaded --- /dev/null +++ b/extra/math/bitfields/lib/lib-docs.factor @@ -0,0 +1,16 @@ +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" } +} ; + diff --git a/extra/math/bitfields/lib/lib-tests.factor b/extra/math/bitfields/lib/lib-tests.factor new file mode 100644 index 0000000000..c002240e69 --- /dev/null +++ b/extra/math/bitfields/lib/lib-tests.factor @@ -0,0 +1,14 @@ +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 diff --git a/extra/math/bitfields/lib/lib.factor b/extra/math/bitfields/lib/lib.factor new file mode 100644 index 0000000000..4a8f3835ca --- /dev/null +++ b/extra/math/bitfields/lib/lib.factor @@ -0,0 +1,31 @@ +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 +: 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 +: 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 ] 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 ; + From 53d21c6c7a8c69351147b4ce73ba4a869b086ed0 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 13:57:33 -0500 Subject: [PATCH 430/886] cleanup in aisle crypto --- extra/crypto/barrett/barrett.factor | 8 +++++++- extra/crypto/common/common.factor | 3 +-- extra/crypto/hmac/hmac-tests.factor | 1 - extra/crypto/hmac/hmac.factor | 1 - extra/crypto/md5/md5.factor | 6 +++--- extra/crypto/rsa/rsa.factor | 6 +++--- extra/crypto/test/common.factor | 15 --------------- extra/crypto/timing/timing.factor | 5 ++--- extra/crypto/xor/xor.factor | 6 +++--- 9 files changed, 19 insertions(+), 32 deletions(-) delete mode 100644 extra/crypto/test/common.factor diff --git a/extra/crypto/barrett/barrett.factor b/extra/crypto/barrett/barrett.factor index 55da97202f..4a070190e3 100644 --- a/extra/crypto/barrett/barrett.factor +++ b/extra/crypto/barrett/barrett.factor @@ -4,5 +4,11 @@ IN: crypto.barrett : 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 ; + diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor index b9f1d43784..a714727ad9 100644 --- a/extra/crypto/common/common.factor +++ b/extra/crypto/common/common.factor @@ -50,9 +50,8 @@ SYMBOL: big-endian? : 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 ; diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor index fa0cbef4c7..eff95bbcd6 100755 --- a/extra/crypto/hmac/hmac-tests.factor +++ b/extra/crypto/hmac/hmac-tests.factor @@ -9,4 +9,3 @@ IN: crypto.hmac.tests [ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 "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 50 HEX: dd >byte-array byte-array>sha1-hmac >string ] unit-test - diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor index 3dad01fe3a..91d404aead 100755 --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -37,7 +37,6 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; : byte-array>sha1-hmac ( K string -- hmac ) binary stream>sha1-hmac ; - : stream>md5-hmac ( K stream -- hmac ) [ init-hmac md5-hmac ] with-stream ; diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor index 7ecbd767b9..45e10da74d 100755 --- a/extra/crypto/md5/md5.factor +++ b/extra/crypto/md5/md5.factor @@ -3,7 +3,7 @@ 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 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 diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor index ccf17da4e8..5d3228db10 100644 --- a/extra/crypto/rsa/rsa.factor +++ b/extra/crypto/rsa/rsa.factor @@ -1,5 +1,5 @@ USING: math.miller-rabin kernel math math.functions namespaces -sequences ; +sequences accessors ; IN: crypto.rsa ! The private key is the only secret. @@ -39,7 +39,7 @@ PRIVATE> public-key ; : 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 ; diff --git a/extra/crypto/test/common.factor b/extra/crypto/test/common.factor deleted file mode 100644 index 6050454402..0000000000 --- a/extra/crypto/test/common.factor +++ /dev/null @@ -1,15 +0,0 @@ -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 - - diff --git a/extra/crypto/timing/timing.factor b/extra/crypto/timing/timing.factor index da2603d92c..a17d65d90b 100644 --- a/extra/crypto/timing/timing.factor +++ b/extra/crypto/timing/timing.factor @@ -1,7 +1,6 @@ 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 diff --git a/extra/crypto/xor/xor.factor b/extra/crypto/xor/xor.factor index 0713e19843..247387ebdf 100644 --- a/extra/crypto/xor/xor.factor +++ b/extra/crypto/xor/xor.factor @@ -1,8 +1,8 @@ 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 ; From d27252e2321e2ef3f9d218df773592caa32c6b09 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 16:02:37 -0500 Subject: [PATCH 431/886] minor cleanup --- extra/random/mersenne-twister/mersenne-twister.factor | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index d3a5fad4ca..46f2088440 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -15,14 +15,13 @@ TUPLE: mersenne-twister seq i ; : mt-m 397 ; inline : mt-a HEX: 9908b0df ; inline -: calculate-y ( y1 y2 mt -- y ) - tuck +: calculate-y ( n seq -- y ) [ nth 32 mask-bit ] - [ nth 31 bits ] 2bi* bitor ; inline + [ [ 1+ ] [ nth ] bi* 31 bits ] 2bi bitor ; inline -: (mt-generate) ( n mt-seq -- next-mt ) +: (mt-generate) ( n seq -- next-mt ) [ - [ dup 1+ ] [ calculate-y ] bi* + calculate-y [ 2/ ] [ odd? mt-a 0 ? ] bi bitxor ] [ [ mt-m + ] [ nth ] bi* From d2fc408c1b63a375696b94e87d4d42e3bc8fea67 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 17:04:23 -0500 Subject: [PATCH 432/886] Fix Windows launcher --- extra/io/windows/launcher/launcher.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 2724966a8f..f9b2742cda 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -27,8 +27,7 @@ TUPLE: CreateProcess-args "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo "PROCESS_INFORMATION" >>lpProcessInformation TRUE >>bInheritHandles - 0 >>dwCreateFlags - current-directory get (normalize-path) >>lpCurrentDirectory ; + 0 >>dwCreateFlags ; : call-CreateProcess ( CreateProcess-args -- ) { @@ -118,6 +117,7 @@ M: windows run-process* ( process -- handle ) [ dup make-CreateProcess-args tuck fill-redirection + current-directory get (normalize-path) cd dup call-CreateProcess lpProcessInformation>> ] with-destructors ; From e006aca54125cd61fd8f7ba4dafd68f2aef81f94 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 17:33:06 -0500 Subject: [PATCH 433/886] Walker: step directly into the effective method --- core/generic/generic.factor | 2 ++ core/generic/standard/standard.factor | 4 ++++ extra/tools/walker/walker.factor | 18 ++++++++---------- 3 files changed, 14 insertions(+), 10 deletions(-) diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 72948c5473..f41f3ebcd0 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -29,6 +29,8 @@ PREDICATE: method-spec < pair : order ( generic -- seq ) "methods" word-prop keys sort-classes ; +GENERIC: effective-method ( ... generic -- method ) + : next-method-class ( class generic -- class/f ) order [ class< ] with subset reverse dup length 1 = [ drop f ] [ second ] if ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index c36e5f1921..9f9a892fd4 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -118,6 +118,10 @@ M: standard-combination perform-combination M: standard-combination dispatch# #>> ; +M: standard-generic effective-method + [ dispatch# (picker) call ] keep + [ order [ instance? ] with find-last nip ] keep method ; + ERROR: inconsistent-next-method object class generic ; ERROR: no-next-method class generic ; diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index 6bd8ace877..4d1a4da6b1 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -3,7 +3,8 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words -sequences.private assocs models arrays accessors ; +sequences.private assocs models arrays accessors +generic generic.standard ; IN: tools.walker SYMBOL: show-walker-hook ! ( status continuation thread -- ) @@ -68,15 +69,12 @@ M: object add-breakpoint ; : (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 primitive? ] [ execute break ] } + { [ t ] [ word-def (step-into-quot) ] } + } cond ; \ (step-into-execute) t "step-into?" set-word-prop From 9f085cc10a76febc7b77c314b42f7dcad49dfa4a Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 18:11:22 -0500 Subject: [PATCH 434/886] add using --- extra/io/windows/files/files.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index 4f31d2dfce..8bfbff2ba0 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. 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 -combinators.lib io.nonblocking destructors system ; +math.functions sequences namespaces words symbols system +combinators.lib io.nonblocking destructors math.bitfields.lib ; IN: io.windows.files SYMBOLS: +read-only+ +hidden+ +system+ From 4acd587629093d156fe0c20b2822cc3b59ac889f Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 18:34:47 -0500 Subject: [PATCH 435/886] move cwd and cd to private vocabs --- core/debugger/debugger-docs.factor | 3 ++- core/io/files/files-docs.factor | 11 ++++++----- core/io/files/files.factor | 9 ++++++--- extra/editors/jedit/jedit.factor | 2 +- extra/io/unix/files/files.factor | 7 ++++++- extra/io/unix/sockets/sockets.factor | 2 +- extra/io/windows/nt/files/files.factor | 4 ++++ 7 files changed, 26 insertions(+), 12 deletions(-) diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor index f8b53d4abc..ca6aa59cc4 100755 --- a/core/debugger/debugger-docs.factor +++ b/core/debugger/debugger-docs.factor @@ -1,6 +1,7 @@ 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" diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 342967acfc..d1a59f3604 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -197,19 +197,20 @@ HELP: file-contents 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." } +{ $warning "Modifying the current directory through system calls is unsafe. Use the " { $link with-directory } " word 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." } +{ $warning "Modifying the current directory through system calls is unsafe. Use the " { $link with-directory } " word instead." } ; -{ cd cwd with-directory } related-words +{ cd cwd current-directory with-directory } related-words 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." } ; +{ $description "Changes the " { $link current-directory } " variable for the duration of a quotation's execution. Words that use the file-system should call " { $link normalize-path } " in order to obtain a path relative to the current directory." } ; HELP: append-path { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 45bf0602f2..08ec78492a 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -176,15 +176,18 @@ SYMBOL: +unknown+ : directory? ( path -- ? ) file-info file-info-type +directory+ = ; -! Current working directory + + +SYMBOL: current-directory + [ cwd current-directory set-global ] "io.files" add-init-hook : resource-path ( path -- newpath ) diff --git a/extra/editors/jedit/jedit.factor b/extra/editors/jedit/jedit.factor index 92320addef..e4f19781ef 100755 --- a/extra/editors/jedit/jedit.factor +++ b/extra/editors/jedit/jedit.factor @@ -4,7 +4,7 @@ USING: arrays definitions io kernel math 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 ) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index f6bb3edcde..3085827483 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -3,10 +3,13 @@ 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 calendar -io.encodings.binary accessors sequences strings system ; +io.encodings.binary accessors sequences strings system +io.files.private ; IN: io.unix.files + ] [ ] bi getcwd [ (io-error) ] unless* ; @@ -14,6 +17,8 @@ M: unix cwd ( -- path ) M: unix cd ( path -- ) chdir io-error ; +PRIVATE> + : read-flags O_RDONLY ; inline : open-read ( path -- fd ) diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 477757e0ed..a54205a878 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -7,7 +7,7 @@ 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 io.backend io.files system ; +combinators io.backend io.files io.files.private system ; IN: io.unix.sockets : pending-init-error ( port -- ) diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 7bac540ddc..590bc59023 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -5,6 +5,8 @@ alien.c-types alien.arrays sequences combinators combinators.lib sequences.lib ascii splitting alien strings assocs namespaces ; IN: io.windows.nt.files + [ GetCurrentDirectory win32-error=0/f ] keep @@ -13,6 +15,8 @@ M: winnt cwd M: winnt cd SetCurrentDirectory win32-error=0/f ; +PRIVATE> + : unicode-prefix ( -- seq ) "\\\\?\\" ; inline From 344a98802ff651d5e078636ed0983eaecb4e18cb Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 18:36:53 -0500 Subject: [PATCH 436/886] tweak word --- extra/math/bitfields/lib/lib.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/math/bitfields/lib/lib.factor b/extra/math/bitfields/lib/lib.factor index 4a8f3835ca..72b33b9ae7 100644 --- a/extra/math/bitfields/lib/lib.factor +++ b/extra/math/bitfields/lib/lib.factor @@ -4,7 +4,6 @@ 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 -: 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 @@ -18,8 +17,8 @@ IN: math.bitfields.lib : bitroll ( x s w -- y ) [ wrap ] keep - [ shift-mod ] 3keep - [ - ] keep shift-mod bitor ; inline + [ shift-mod ] + [ [ - ] keep shift-mod ] 3bi bitor ; inline : bitroll-32 ( n s -- n' ) 32 bitroll ; From 82f3239012690afbc3f884cb5b6777d63948e976 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 18:40:51 -0500 Subject: [PATCH 437/886] remove private stuff --- extra/io/unix/files/files.factor | 4 ---- extra/io/windows/nt/files/files.factor | 4 ---- 2 files changed, 8 deletions(-) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 3085827483..39c18b4601 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -8,8 +8,6 @@ io.files.private ; IN: io.unix.files - ] [ ] bi getcwd [ (io-error) ] unless* ; @@ -17,8 +15,6 @@ M: unix cwd ( -- path ) M: unix cd ( path -- ) chdir io-error ; -PRIVATE> - : read-flags O_RDONLY ; inline : open-read ( path -- fd ) diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 590bc59023..7bac540ddc 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -5,8 +5,6 @@ alien.c-types alien.arrays sequences combinators combinators.lib sequences.lib ascii splitting alien strings assocs namespaces ; IN: io.windows.nt.files - [ GetCurrentDirectory win32-error=0/f ] keep @@ -15,8 +13,6 @@ M: winnt cwd M: winnt cd SetCurrentDirectory win32-error=0/f ; -PRIVATE> - : unicode-prefix ( -- seq ) "\\\\?\\" ; inline From 45b0dd9042625584bcd936027cd194c67721f8f7 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 18:41:12 -0500 Subject: [PATCH 438/886] add using --- extra/io/windows/nt/files/files.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 7bac540ddc..3232ab6ff3 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -2,7 +2,8 @@ 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 system alien.c-types alien.arrays sequences combinators combinators.lib -sequences.lib ascii splitting alien strings assocs namespaces ; +sequences.lib ascii splitting alien strings assocs namespaces +io.files.private ; IN: io.windows.nt.files M: winnt cwd From 36fc0b26ac9078241223853ae6c50cc002eaaa14 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 18:51:53 -0500 Subject: [PATCH 439/886] fix load error --- extra/io/unix/launcher/launcher.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 8e5531a40c..5f0a9b96cb 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.nonblocking io.unix.backend 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 accessors io.files ; +io.unix.launcher.parser accessors io.files io.files.private ; IN: io.unix.launcher ! Search unix first From 653bc1cd80819cbfb81f2082a8240cfda7a54ab7 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 18:59:04 -0500 Subject: [PATCH 440/886] update docs --- core/io/files/files-docs.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index d1a59f3604..85e17ded46 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -28,11 +28,14 @@ ARTICLE: "pathnames" "Pathname manipulation" { $subsection } ; ARTICLE: "directories" "Directories" -"Current and home directories:" +"Current directory:" +{ $subsection with-directory } +{ $subsection current-directory } +"Home directory:" +{ $subsection home } +"Current system directory:" { $subsection cwd } { $subsection cd } -{ $subsection with-directory } -{ $subsection home } "Directory listing:" { $subsection directory } { $subsection directory* } From 8245d65a6c1b3ee0f41faa5f86676127fbd559d0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 19:08:34 -0500 Subject: [PATCH 441/886] Documentation updates --- core/classes/classes-docs.factor | 8 +- core/classes/mixin/mixin-docs.factor | 2 +- core/classes/tuple/tuple-docs.factor | 150 ++++++++++++++++++---- core/classes/tuple/tuple.factor | 2 +- core/generic/generic-docs.factor | 13 ++ core/kernel/kernel-docs.factor | 21 ++- core/prettyprint/prettyprint-tests.factor | 3 + 7 files changed, 165 insertions(+), 34 deletions(-) diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 3f30b71457..3eaf7243c9 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -38,17 +38,21 @@ $nl { $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 "singletons" } { $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" } ; diff --git a/core/classes/mixin/mixin-docs.factor b/core/classes/mixin/mixin-docs.factor index 1fa6f7bd83..a685d70571 100755 --- a/core/classes/mixin/mixin-docs.factor +++ b/core/classes/mixin/mixin-docs.factor @@ -3,7 +3,7 @@ classes ; 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 } diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 664f0545fa..9ba51d433f 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -3,14 +3,63 @@ classes.tuple.private classes slots quotations words arrays generic.standard sequences definitions compiler.units ; IN: classes.tuple -ARTICLE: "tuple-constructors" "Constructors" -"Tuples are created by calling one of two words:" +ARTICLE: "parametrized-constructors" "Parameterized constructors" +"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link construct-empty } " or " { $link construct-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 ;" + ": ( max-speed engine -- car )" + " car construct-empty" + " V{ } clone >>occupants" + " swap >>engine" + " swap >>max-speed ;" + "" + "TUPLE: aeroplane < vehicle max-altitude ;" + ": ( max-speed max-altitude -- aeroplane )" + " aeroplane construct-empty" + " 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 ;" + "" + ": construct-vehicle ( class -- vehicle )" + " construct-empty" + " V{ } clone >>occupants ;" + "" + "TUPLE: car < vehicle engine ;" + ": ( max-speed engine -- car )" + " car construct-vehicle" + " swap >>engine" + " swap >>max-speed ;" + "" + "TUPLE: aeroplane < vehicle max-altitude ;" + ": ( max-speed max-altitude -- aeroplane )" + " aeroplane construct-vehicle" + " swap >>max-altitude" + " swap >>max-speed ;" +} +"The naming convention for parametrized constructors is " { $snippet "construct-" { $emphasis "class" } } "." ; + +ARTICLE: "tuple-constructors" "Tuple constructors" +"Tuples are created by calling one of two constructor primitives:" { $subsection construct-empty } { $subsection construct-boa } -"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 "" } "." -$nl "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 "" } "." +$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 ;" @@ -22,29 +71,76 @@ $nl "" ": construct-empty ;" ": f f f f ; ! identical to above" +} +{ $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-delegation" "Tuple 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." +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 -"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." +"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 ... ;" +} +{ $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 -"A pair of words examine delegation chains:" -{ $subsection delegates } -{ $subsection is? } -"An example:" -{ $example - "TUPLE: ellipse center radius ;" - "TUPLE: colored color ;" - "{ 0 0 } 10 \"my-ellipse\" set" - "{ 1 0 0 } \"my-shape\" set" - "\"my-ellipse\" get \"my-shape\" get set-delegate" - "\"my-shape\" get dup color>> swap center>> .s" - "{ 0 0 }\n{ 1 0 0 }" -} ; +"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 construct-empty } ", " { $link construct-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" } ; 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." @@ -119,7 +215,8 @@ ARTICLE: "tuple-examples" "Tuple examples" ": promote ( person -- person )" " [ 1.2 * ] change-salary" " [ next-position ] change-position ;" -} ; +} +"An example using subclassing can be found in " { $link "tuple-inheritance-example" } "." ; ARTICLE: "tuples" "Tuples" "Tuples are user-defined classes composed of named slots." @@ -132,8 +229,9 @@ $nl { $subsection "accessors" } "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" } +"Expressing relationships through the object system:" +{ $subsection "tuple-subclassing" } +"Introspection:" { $subsection "tuple-introspection" } "Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index b1cb3f8a66..00178fd73e 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -162,7 +162,7 @@ M: tuple-class update-class : define-new-tuple-class ( class superclass slots -- ) [ drop f tuple-class define-class ] - [ nip "slot-names" set-word-prop ] + [ nip [ dup array? [ second ] when ] map "slot-names" set-word-prop ] [ 2drop update-classes ] 3tri ; diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 04252b6b3b..2034bcf76b 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -37,6 +37,8 @@ $nl { $subsection create-method } "Method definitions can be looked up:" { $subsection method } +"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:" @@ -64,6 +66,16 @@ $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." { $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 } ; + 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 @@ -81,6 +93,7 @@ $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." ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 53618d4628..328a647339 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -276,6 +276,7 @@ ARTICLE: "dataflow" "Data and control flow" { $subsection "apply-combinators" } { $subsection "slip-keep-combinators" } { $subsection "conditionals" } +{ $subsection "compositional-combinators" } { $subsection "combinators" } "Advanced topics:" { $subsection "implementing-combinators" } @@ -846,11 +847,15 @@ HELP: with { $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" @@ -862,7 +867,15 @@ HELP: 3compose { $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" diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 0f384b159d..e94670992c 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -333,3 +333,6 @@ 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 From 90d4266867eb6af40590f1b05208b1db29aa763a Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 3 Apr 2008 19:17:58 -0500 Subject: [PATCH 442/886] Part of delegate changes --- extra/delegate/delegate-tests.factor | 8 +++++++- extra/delegate/delegate.factor | 18 ++++++++++++++---- 2 files changed, 21 insertions(+), 5 deletions(-) diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor index d66357daa5..2a0e013c1a 100644 --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -1,6 +1,12 @@ -USING: delegate kernel arrays tools.test ; +USING: delegate kernel arrays tools.test words math ; 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 diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 7f24d6258f..8ca99ec565 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -1,6 +1,7 @@ ! 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 ; IN: delegate : define-protocol ( wordlist protocol -- ) @@ -18,7 +19,7 @@ M: protocol group-words "protocol-words" word-prop ; M: generic group-words - 1array ; + 1array ; M: tuple-class group-words "slots" word-prop 1 tail ! The first slot is the delegate @@ -27,10 +28,19 @@ M: tuple-class group-words swap [ slot-spec-writer ] map append ; : define-consult-method ( word class quot -- ) - pick add >r swap create-method r> define ; + pick add >r swap create-method-in r> define ; + +: 3bi ( x y z p q -- p(x,y,z) q(x,y,z) ) + >r 3keep r> call ; inline + +: change-word-prop ( word prop quot -- ) + >r swap word-props r> change-at ; inline + +: declare-consult ( class group -- ) + "protocol-users" [ ?push ] change-word-prop ; : define-consult ( class group quot -- ) - >r group-words swap r> + >r 2dup declare-consult group-words swap r> [ define-consult-method ] 2curry each ; : CONSULT: From cc2f512287127d9f1f1e57178ab8699cf2e6d9e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 21:19:20 -0500 Subject: [PATCH 443/886] New classes.builtin vocab --- core/bootstrap/image/image.factor | 6 ++-- core/bootstrap/primitives.factor | 8 ++--- core/classes/algebra/algebra.factor | 8 ++--- core/classes/builtin/builtin-docs.factor | 28 +++++++++++++++ core/classes/builtin/builtin.factor | 18 ++++++++++ core/classes/classes-docs.factor | 27 +------------- core/classes/classes.factor | 13 ------- core/classes/singleton/singleton-docs.factor | 26 ++++++++------ core/classes/tuple/tuple.factor | 7 ++-- core/debugger/debugger.factor | 6 ++-- core/generic/generic-docs.factor | 10 +++++- core/generic/math/math.factor | 3 +- core/generic/standard/standard-docs.factor | 38 +++++++++++++++++++- core/layouts/layouts-docs.factor | 2 +- core/prettyprint/prettyprint.factor | 6 ++-- core/slots/slots-docs.factor | 4 +-- core/syntax/syntax-docs.factor | 17 ++++++++- extra/help/handbook/handbook.factor | 3 +- 18 files changed, 153 insertions(+), 77 deletions(-) create mode 100644 core/classes/builtin/builtin-docs.factor create mode 100644 core/classes/builtin/builtin.factor diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 6e0f8e2970..05d48af2e8 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -4,9 +4,9 @@ USING: alien arrays bit-arrays byte-arrays generic assocs 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 classes.tuple classes.tuple.private -words.private io.binary io.files vocabs vocabs.loader -source-files definitions debugger float-arrays +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 diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 6c87730278..516ff7ed74 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -3,10 +3,10 @@ USING: alien arrays byte-arrays generic hashtables hashtables.private io kernel math namespaces parser sequences strings vectors words quotations assocs layouts classes -classes.tuple classes.tuple.private kernel.private vocabs -vocabs.loader source-files definitions slots.deprecated -classes.union compiler.units bootstrap.image.private io.files -accessors combinators ; +classes.builtin classes.tuple classes.tuple.private +kernel.private vocabs vocabs.loader source-files definitions +slots.deprecated classes.union compiler.units +bootstrap.image.private io.files accessors combinators ; IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 97309dbea2..4614e4c4ce 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel classes combinators accessors sequences arrays -vectors assocs namespaces words sorting layouts math hashtables -kernel.private ; +USING: kernel classes classes.builtin combinators accessors +sequences arrays vectors assocs namespaces words sorting layouts +math hashtables kernel.private ; IN: classes.algebra : 2cache ( key1 key2 assoc quot -- value ) @@ -103,7 +103,7 @@ C: anonymous-complement { { [ over tuple eq? ] [ 2drop t ] } { [ over builtin-class? ] [ 2drop f ] } - { [ over tuple-class? ] [ [ class< ] 2keep swap class< or ] } + { [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] } { [ t ] [ swap classes-intersect? ] } } cond ; diff --git a/core/classes/builtin/builtin-docs.factor b/core/classes/builtin/builtin-docs.factor new file mode 100644 index 0000000000..6c5c262087 --- /dev/null +++ b/core/classes/builtin/builtin-docs.factor @@ -0,0 +1,28 @@ +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 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: 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 } "." } ; + diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor new file mode 100644 index 0000000000..1c2871b031 --- /dev/null +++ b/core/classes/builtin/builtin.factor @@ -0,0 +1,18 @@ +! 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 ; diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 3eaf7243c9..dd3782e877 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -4,14 +4,6 @@ layouts classes.private classes.union classes.mixin 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-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 @@ -62,37 +54,20 @@ ABOUT: "classes" 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: builtins -{ $var-description "Vector mapping type numbers to builtin class words." } ; - 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." } ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index c45fd7360b..b22e21eb92 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -30,20 +30,11 @@ SYMBOL: update-map PREDICATE: class < word "class" word-prop ; -SYMBOL: builtins - -PREDICATE: builtin-class < class - "metaclass" word-prop builtin-class eq? ; - PREDICATE: tuple-class < class "metaclass" word-prop tuple-class eq? ; : classes ( -- seq ) all-words [ class? ] subset ; -: type>class ( n -- class ) builtins get-global nth ; - -: bootstrap-type>class ( n -- class ) builtins get nth ; - : predicate-word ( word -- predicate ) [ word-name "?" append ] keep word-vocabulary create ; @@ -130,9 +121,5 @@ GENERIC: update-methods ( assoc -- ) GENERIC: class ( object -- class ) -M: hi-tag class hi-tag type>class ; - -M: object class tag type>class ; - : instance? ( obj class -- ? ) "predicate" word-prop call ; diff --git a/core/classes/singleton/singleton-docs.factor b/core/classes/singleton/singleton-docs.factor index 8548f84a3a..a8dae809ec 100644 --- a/core/classes/singleton/singleton-docs.factor +++ b/core/classes/singleton/singleton-docs.factor @@ -2,27 +2,33 @@ 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. Methods may dispatch off of singleton classes." +"A singleton is a class with only one instance and with no state." { $subsection POSTPONE: SINGLETON: } -{ $subsection define-singleton-class } ; +{ $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 +{ $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 +} +{ $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!" } -} { $see-also - POSTPONE: PREDICATE: } ; HELP: define-singleton-class { $values { "word" "a new word" } } { $description - "Defines a newly created word to be a singleton class." } ; + "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" diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 00178fd73e..ef81a0c953 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -56,7 +56,8 @@ PRIVATE> unclip slots>tuple ; : slot-names ( class -- seq ) - "slot-names" word-prop ; + "slot-names" word-prop + [ dup array? [ second ] when ] map ; over superclass-size 2 + simple-slots ; : define-tuple-slots ( class -- ) - dup dup slot-names generate-tuple-slots + dup dup "slot-names" word-prop generate-tuple-slots [ "slots" set-word-prop ] [ define-accessors ] ! new [ define-slots ] ! old @@ -162,7 +163,7 @@ M: tuple-class update-class : define-new-tuple-class ( class superclass slots -- ) [ drop f tuple-class define-class ] - [ nip [ dup array? [ second ] when ] map "slot-names" set-word-prop ] + [ nip "slot-names" set-word-prop ] [ 2drop update-classes ] 3tri ; diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 033ae0680c..77e8f0ac05 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -4,9 +4,9 @@ USING: arrays definitions generic hashtables inspector io kernel math namespaces prettyprint sequences assocs sequences.private strings io.styles vectors words system splitting math.parser classes.tuple continuations continuations.private combinators -generic.math io.streams.duplex classes compiler.units -generic.standard vocabs threads threads.private init -kernel.private libc io.encodings ; +generic.math io.streams.duplex classes.builtin classes +compiler.units generic.standard vocabs threads threads.private +init kernel.private libc io.encodings ; IN: debugger GENERIC: error. ( error -- ) diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 2034bcf76b..1024c377a8 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -74,7 +74,10 @@ $nl "A lower-level word which the above expands into:" { $subsection (call-next-method) } "To look up the next applicable method reflectively:" -{ $subsection next-method } ; +{ $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." @@ -160,3 +163,8 @@ HELP: forget-methods { $description "Remove all method definitions which specialize on the class." } ; { 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." } ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 46208744f0..fce908bdef 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -2,7 +2,8 @@ ! 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 classes.algebra definitions ; +sequences.private classes classes.builtin classes.algebra +definitions ; IN: generic.math PREDICATE: math-class < class diff --git a/core/generic/standard/standard-docs.factor b/core/generic/standard/standard-docs.factor index a6a65bb62f..09746d35f5 100644 --- a/core/generic/standard/standard-docs.factor +++ b/core/generic/standard/standard-docs.factor @@ -1,4 +1,5 @@ -USING: generic help.markup help.syntax sequences ; +USING: generic help.markup help.syntax sequences math +math.parser ; IN: generic.standard HELP: no-method @@ -31,3 +32,38 @@ HELP: define-simple-generic { $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 ;" } +} ; diff --git a/core/layouts/layouts-docs.factor b/core/layouts/layouts-docs.factor index 089465177b..a54df30c50 100755 --- a/core/layouts/layouts-docs.factor +++ b/core/layouts/layouts-docs.factor @@ -1,6 +1,6 @@ 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 diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index fd7133053a..03d3e456ca 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -5,9 +5,9 @@ USING: alien 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 classes.tuple io.files classes continuations -hashtables classes.mixin classes.union classes.predicate -classes.singleton combinators quotations ; +definitions effects classes.builtin classes.tuple io.files +classes continuations hashtables classes.mixin classes.union +classes.predicate classes.singleton combinators quotations ; : make-pprint ( obj quot -- block in use ) [ diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 2b0d721f3e..29facb31f2 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -1,7 +1,7 @@ USING: help.markup help.syntax generic kernel.private parser words kernel quotations namespaces sequences words arrays -effects generic.standard classes.tuple slots.private classes -strings math ; +effects generic.standard classes.tuple classes.builtin +slots.private classes strings math ; IN: slots ARTICLE: "accessors" "Slot accessors" diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index b242e65de5..39a4d266e9 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -1,6 +1,7 @@ USING: generic help.syntax help.markup kernel math parser words effects classes generic.standard classes.tuple generic.math -arrays io.files vocabs.loader io sequences assocs ; +generic.standard arrays io.files vocabs.loader io sequences +assocs ; IN: syntax ARTICLE: "parser-algorithm" "Parser algorithm" @@ -633,4 +634,18 @@ HELP: >> { $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 diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 847a5952af..acdbca82ee 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -2,7 +2,8 @@ USING: help help.markup help.syntax help.definitions help.topics 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 ; IN: help.handbook ARTICLE: "conventions" "Conventions" From f2440381cd45714eff023332128a3a519400df05 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 21:29:49 -0500 Subject: [PATCH 444/886] More documentation updates --- core/classes/mixin/mixin-docs.factor | 6 ++++-- core/classes/tuple/tuple-docs.factor | 2 +- core/classes/union/union-docs.factor | 4 +++- 3 files changed, 8 insertions(+), 4 deletions(-) diff --git a/core/classes/mixin/mixin-docs.factor b/core/classes/mixin/mixin-docs.factor index a685d70571..82dec5cec0 100755 --- a/core/classes/mixin/mixin-docs.factor +++ b/core/classes/mixin/mixin-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax help words compiler.units -classes ; +classes sequences ; IN: classes.mixin ARTICLE: "mixins" "Mixin classes" @@ -10,7 +10,9 @@ ARTICLE: "mixins" "Mixin classes" { $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." } ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 9ba51d433f..87e035958b 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -140,7 +140,7 @@ $nl } { $subsection "tuple-inheritance-example" } { $subsection "tuple-inheritance-anti-example" } -{ $see-also "call-next-method" "parametrized-constructors" } ; +{ $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." diff --git a/core/classes/union/union-docs.factor b/core/classes/union/union-docs.factor index 237f32c3e0..91726b6697 100755 --- a/core/classes/union/union-docs.factor +++ b/core/classes/union/union-docs.factor @@ -11,7 +11,9 @@ ARTICLE: "unions" "Union classes" { $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" From dbb0cf55cca93b0e7fd9cebd172b44202b8d97de Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 21:29:56 -0500 Subject: [PATCH 445/886] Fix UI completion bug --- extra/ui/tools/listener/listener.factor | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 7db0d63f45..52c3d2de42 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -1,4 +1,4 @@ -! 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 @@ -7,7 +7,7 @@ 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 -math arrays ; +math arrays generic accessors ; IN: ui.tools.listener TUPLE: listener-gadget input output stack ; @@ -101,16 +101,26 @@ M: listener-operation invoke-command ( target command -- ) : 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? +GENERIC# word-completion-string 1 ( word listener -- string ) + +M: method-body word-completion-string + >r "method-generic" word-prop r> word-completion-string ; + +USE: generic.standard.engines.tuple + +M: tuple-dispatch-engine-word word-completion-string + >r "engine-generic" word-prop r> word-completion-string ; + +M: word word-completion-string ( word listener -- string ) + >r [ word-name ] [ word-vocabulary ] bi dup vocab-words r> + input>> interactor-use memq? [ drop ] [ [ "USE: " % % " " % % ] "" make ] if ; : insert-word ( word -- ) get-workspace workspace-listener [ word-completion-string ] keep - listener-gadget-input user-input ; + input>> user-input ; : quot-action ( interactor -- lines ) dup control-value From e22a7a610047cc2bf768940ba64543c5f4b94937 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 3 Apr 2008 21:39:52 -0500 Subject: [PATCH 446/886] update docs pl0x --- core/io/files/files-docs.factor | 155 +++++++++++++++++++++++--------- core/io/files/files.factor | 8 +- 2 files changed, 115 insertions(+), 48 deletions(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 85e17ded46..1dd96a13fc 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -11,7 +11,9 @@ ARTICLE: "file-streams" "Reading and writing files" { $subsection with-file-reader } { $subsection with-file-writer } { $subsection with-file-appender } +{ $subsection set-file-contents } { $subsection file-contents } +{ $subsection set-file-lines } { $subsection file-lines } ; ARTICLE: "pathnames" "Pathname manipulation" @@ -27,15 +29,22 @@ ARTICLE: "pathnames" "Pathname manipulation" { $subsection pathname } { $subsection } ; +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: "directories" "Directories" "Current directory:" -{ $subsection with-directory } { $subsection current-directory } +{ $subsection set-current-directory } +{ $subsection with-directory } "Home directory:" { $subsection home } -"Current system directory:" -{ $subsection cwd } -{ $subsection cd } "Directory listing:" { $subsection directory } { $subsection directory* } @@ -43,18 +52,26 @@ ARTICLE: "directories" "Directories" { $subsection make-directory } { $subsection make-directories } ; -! ARTICLE: "file-types" "File Types" - -! { $table { +directory+ "" } } - -! ; - -ARTICLE: "fs-meta" "File meta-data" +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 directory? } +"File types:" +{ $subsection "file-types" } ; ARTICLE: "delete-move-copy" "Deleting, moving, copying files" "Operations for deleting and copying files come in two forms:" @@ -123,39 +140,40 @@ HELP: file-name ! need a $class-description file-info HELP: file-info - - { $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." } - - { $class-description "File meta data" } - - { $table - { "type" { "One of the following:" - { $list { $link +regular-file+ } - { $link +directory+ } - { $link +symbolic-link+ } } } } - - { "size" "Size of the file in bytes" } - { "modified" "Last modification timestamp." } } - - ; - -! need a see also to link-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." } ; 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 +{ $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." } ; { file-info link-info } related-words +HELP: +regular-file+ +{ $description "A regular file. This type exists on all platforms. See " { $link "file-streams" } " for words operating on files." } ; + +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." } ; + +HELP: +character-device+ +{ $description "A Unix character device file. This type exists on unix platforms only." } ; + +HELP: +block-device+ +{ $description "A Unix block device file. This type exists on unix platforms only." } ; + +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: { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } } { "stream" "an input stream" } } @@ -187,29 +205,44 @@ HELP: with-file-appender { $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." } -{ $warning "Modifying the current directory through system calls is unsafe. Use the " { $link with-directory } " word instead." } ; +{ $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." } -{ $warning "Modifying the current directory through system calls is unsafe. Use the " { $link with-directory } " word instead." } ; +{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ; -{ cd cwd current-directory 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. Words that use the filesystem do so in relation to this variable. On startup, an init hook sets this word to the directory from which Factor was run." } ; HELP: with-directory { $values { "path" "a pathname string" } { "quot" quotation } } @@ -219,6 +252,26 @@ HELP: append-path { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } { $description "Concatenates two pathnames." } ; +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." } ; @@ -264,6 +317,20 @@ HELP: ( 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." } ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 08ec78492a..ed1b94e556 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -153,19 +153,19 @@ HOOK: file-info io-backend ( path -- info ) ! Symlinks HOOK: link-info io-backend ( path -- info ) -HOOK: make-link io-backend ( path1 path2 -- ) +HOOK: make-link io-backend ( target symlink -- ) -HOOK: read-link io-backend ( path -- info ) +HOOK: read-link io-backend ( symlink -- path ) -: copy-link ( path1 path2 -- ) +: 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+ From 76581ad6d08a5564bc4171aa3971eed2263981f2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 21:43:41 -0500 Subject: [PATCH 447/886] Remove crappy parser feature --- core/parser/parser-docs.factor | 8 ------ core/parser/parser-tests.factor | 41 --------------------------- core/parser/parser.factor | 41 ++++++--------------------- core/source-files/source-files.factor | 18 ++++++------ 4 files changed, 17 insertions(+), 91 deletions(-) diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index cc4e2c0a42..61fd9f7f30 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -445,18 +445,10 @@ HELP: eval { $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." } ; - HELP: forget-smudged { $description "Forgets removed definitions and prints a warning message if any of them are still referenced from other source files." } ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 6bd4abb7e1..ab9648c527 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -348,47 +348,6 @@ IN: parser.tests ] must-fail ] with-file-vocabs -[ - << file get parsed >> file set - - : ~a ; - - DEFER: ~b - - "IN: parser.tests : ~b ~a ;" - "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: foo < object ( x -- y ) ;" eval ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 902bae29b5..8fcbad4d3c 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -464,19 +464,6 @@ SYMBOL: interactive-vocabs "Loading " write . 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 ( assoc1 assoc2 -- seq ) diff [ drop where dup [ first ] when @@ -491,32 +478,22 @@ SYMBOL: interactive-vocabs new-definitions old-definitions [ get second ] bi@ ; -: smudged-usage ( -- usages referenced removed ) - removed-definitions filter-moved [ - 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 ; +: 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 - filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each - removed-classes - filter-moved [ class? ] subset [ reset-class ] each ; + 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 -- ) diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 8dea367b6b..5df5f503f9 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -56,10 +56,14 @@ uses definitions ; 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 ; @@ -78,9 +82,3 @@ 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 ; From 1e538ccd03cf725fe71fe6dec5b2acd7e8507bbb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 3 Apr 2008 22:16:37 -0500 Subject: [PATCH 448/886] more docs --- core/kernel/kernel-docs.factor | 5 ++++- core/math/math-docs.factor | 23 +++++++++++++++++++++++ 2 files changed, 27 insertions(+), 1 deletion(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 53618d4628..6c71db9e61 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -341,6 +341,9 @@ HELP: set-callstack ( cs -- ) 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:" @@ -393,7 +396,7 @@ HELP: identity-tuple 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 diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 6ec1c5790f..5533c00090 100755 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -83,6 +83,29 @@ HELP: >= { $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 From d031087338d4d4be434c85695a1c0fc456eaafae Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 3 Apr 2008 23:35:57 -0500 Subject: [PATCH 449/886] better cpu report --- extra/hardware-info/backend/backend.factor | 1 + extra/hardware-info/hardware-info.factor | 4 +++- extra/hardware-info/macosx/macosx.factor | 2 +- 3 files changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/hardware-info/backend/backend.factor b/extra/hardware-info/backend/backend.factor index 95a56da2d2..283fea6fcc 100644 --- a/extra/hardware-info/backend/backend.factor +++ b/extra/hardware-info/backend/backend.factor @@ -2,6 +2,7 @@ USING: system ; IN: hardware-info.backend HOOK: cpus os ( -- n ) +HOOK: cpu-mhz os ( -- n ) HOOK: memory-load os ( -- n ) HOOK: physical-mem os ( -- n ) HOOK: available-mem os ( -- n ) diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor index 6d27cf5252..53aab483a1 100755 --- a/extra/hardware-info/hardware-info.factor +++ b/extra/hardware-info/hardware-info.factor @@ -3,11 +3,12 @@ combinators vocabs.loader hardware-info.backend system ; IN: hardware-info : write-unit ( x n str -- ) - [ 2^ /i number>string write bl ] [ write ] bi* ; + [ 2^ /f number>string write bl ] [ write ] bi* ; : 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" ] } @@ -18,4 +19,5 @@ IN: hardware-info : hardware-report. ( -- ) "CPUs: " write cpus number>string write nl + "CPU Speed: " write cpu-mhz ghz nl "Physical RAM: " write physical-mem megs nl ; diff --git a/extra/hardware-info/macosx/macosx.factor b/extra/hardware-info/macosx/macosx.factor index dac052a1de..91838d2a53 100644 --- a/extra/hardware-info/macosx/macosx.factor +++ b/extra/hardware-info/macosx/macosx.factor @@ -41,7 +41,7 @@ M: macosx physical-mem ( -- n ) { 6 5 } 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 ; From 3eb2bd784f8c633840afa5796cdd49637ea01714 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 3 Apr 2008 23:36:14 -0500 Subject: [PATCH 450/886] fix library path --- extra/db/postgresql/ffi/ffi.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index 7925989bf5..7f428bb6b6 100755 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -6,7 +6,8 @@ IN: db.postgresql.ffi << "postgresql" { { [ os winnt? ] [ "libpq.dll" ] } - { [ os macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] } + { [ os macosx? ] [ "/opt/local/lib/postgresql83/libpq.dylib" ] } + ! { [ os macosx? ] [ "libpq.dylib" ] } { [ os unix? ] [ "libpq.so" ] } } cond "cdecl" add-library >> From ef4046cda9f3d8ed6c3b901151090962df79406a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 00:33:06 -0500 Subject: [PATCH 451/886] Converting code to use inheritance --- core/alien/alien.factor | 6 - core/alien/compiler/compiler.factor | 54 ++++--- core/bootstrap/compiler/compiler.factor | 2 - core/classes/algebra/algebra-tests.factor | 12 +- core/classes/tuple/tuple-docs.factor | 24 +--- core/classes/tuple/tuple-tests.factor | 24 ---- core/compiler/tests/tuples.factor | 8 -- core/continuations/continuations.factor | 24 ++-- core/debugger/debugger.factor | 14 +- core/generic/standard/standard-docs.factor | 2 +- core/heaps/heaps-tests.factor | 9 +- core/heaps/heaps.factor | 26 ++-- core/inference/backend/backend.factor | 14 +- core/inference/dataflow/dataflow.factor | 149 ++++++++++---------- core/inference/errors/errors.factor | 8 +- core/inference/inference-docs.factor | 2 +- core/inference/inference-tests.factor | 5 + core/io/streams/string/string-docs.factor | 2 +- core/listener/listener.factor | 4 +- core/optimizer/backend/backend.factor | 2 +- core/optimizer/def-use/def-use.factor | 2 +- core/parser/parser.factor | 31 ++-- core/refs/refs-tests.factor | 22 +++ core/refs/refs.factor | 15 +- core/source-files/source-files.factor | 2 +- extra/help/crossref/crossref.factor | 2 +- extra/ui/tools/interactor/interactor.factor | 7 +- 27 files changed, 226 insertions(+), 246 deletions(-) create mode 100644 core/refs/refs-tests.factor diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 56be3e66a5..2f82e5db98 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -62,22 +62,16 @@ TUPLE: library path abi dll ; : add-library ( name path abi -- ) swap libraries get set-at ; -TUPLE: alien-callback return parameters abi quot xt ; - ERROR: alien-callback-error ; : alien-callback ( return parameters abi quot -- alien ) alien-callback-error ; -TUPLE: alien-indirect return parameters abi ; - ERROR: alien-indirect-error ; : alien-indirect ( ... funcptr return parameters abi -- ) alien-indirect-error ; -TUPLE: alien-invoke library function return parameters abi ; - ERROR: alien-invoke-error library symbol ; : alien-invoke ( ... return library function parameters -- ... ) diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 1a9d5b5392..ea9476a08a 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -9,6 +9,14 @@ kernel.private threads continuations.private libc combinators compiler.errors continuations layouts accessors ; IN: alien.compiler +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 @@ -229,32 +237,32 @@ M: no-such-symbol compiler-error-type ] 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 construct-empty ! 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 ! Set ABI - dup alien-invoke-library - library [ library-abi ] [ "cdecl" ] if* - over set-alien-invoke-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 ] "infer" set-word-prop -M: alien-invoke generate-node +M: #alien-invoke generate-node dup alien-invoke-frame [ end-basic-block %prepare-alien-invoke @@ -273,11 +281,11 @@ M: alien-indirect-error summary ! Three literals and function pointer 4 ensure-values 4 reify-curries - \ alien-indirect empty-node + #alien-indirect construct-empty ! 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 ! Add node to IR @@ -286,7 +294,7 @@ M: alien-indirect-error summary 1 alien-invoke-stack ] "infer" set-word-prop -M: alien-indirect generate-node +M: #alien-indirect generate-node dup alien-invoke-frame [ ! Flush registers end-basic-block @@ -320,12 +328,12 @@ M: alien-callback-error summary \ 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 construct-empty 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 @@ -398,5 +406,5 @@ TUPLE: callback-context ; ] with-stack-frame ] with-generator ; -M: alien-callback generate-node +M: #alien-callback generate-node end-basic-block generate-callback iterate-next ; diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 6b467caa5a..618c62f332 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -37,8 +37,6 @@ nl wrap probe - delegate - underlying find-pair-next namestack* diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 0f468908a9..d61b62af3b 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -68,13 +68,13 @@ UNION: c a b ; [ t ] [ \ tuple-class \ class class< ] unit-test [ f ] [ \ class \ tuple-class class< ] unit-test -TUPLE: delegate-clone ; +TUPLE: tuple-example ; -[ 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 +[ t ] [ \ null \ tuple-example class< ] unit-test +[ f ] [ \ object \ tuple-example class< ] unit-test +[ f ] [ \ object \ tuple-example class< ] unit-test +[ t ] [ \ tuple-example \ tuple class< ] unit-test +[ f ] [ \ tuple \ tuple-example class< ] unit-test TUPLE: a1 ; TUPLE: b1 ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 87e035958b..0abfb8851f 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -121,6 +121,7 @@ $nl "..." "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 @@ -237,15 +238,6 @@ $nl 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." } @@ -299,26 +291,16 @@ HELP: define-tuple-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." +{ $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 the second is the delegate; the remainder are declared slots." } ; +{ $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: ( layout -- tuple ) { $values { "layout" tuple-layout } { "tuple" tuple } } diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index a8e9066f56..25d163d9cd 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -16,25 +16,6 @@ TUPLE: rect x y w h ; [ t ] [ 10 20 30 40 dup clone 0 swap move = ] unit-test -GENERIC: delegation-test -M: object delegation-test drop 3 ; -TUPLE: quux-tuple ; -: quux-tuple construct-empty ; -M: quux-tuple delegation-test drop 4 ; -TUPLE: quuux-tuple ; -: { set-delegate } quuux-tuple construct ; - -[ 3 ] [ delegation-test ] unit-test - -GENERIC: delegation-test-2 -TUPLE: quux-tuple-2 ; -: quux-tuple-2 construct-empty ; -M: quux-tuple-2 delegation-test-2 drop 4 ; -TUPLE: quuux-tuple-2 ; -: { set-delegate } quuux-tuple-2 construct ; - -[ 4 ] [ delegation-test-2 ] unit-test - ! Make sure we handle tuple class redefinition TUPLE: redefinition-test ; @@ -102,11 +83,6 @@ C: empty [ t ] [ hashcode fixnum? ] unit-test -TUPLE: delegate-clone ; - -[ T{ delegate-clone T{ empty f } } ] -[ T{ delegate-clone T{ empty f } } clone ] unit-test - ! Compiler regression [ t length ] [ object>> t eq? ] must-fail-with diff --git a/core/compiler/tests/tuples.factor b/core/compiler/tests/tuples.factor index 5843575eeb..97cde6261c 100755 --- a/core/compiler/tests/tuples.factor +++ b/core/compiler/tests/tuples.factor @@ -22,11 +22,3 @@ TUPLE: color red green blue ; [ 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 diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index a2c296e8ce..cf67280cca 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -141,14 +141,9 @@ GENERIC: dispose ( object -- ) : with-disposal ( object quot -- ) over [ dispose ] curry [ ] cleanup ; inline -TUPLE: condition restarts continuation ; +TUPLE: condition error restarts continuation ; -: ( error restarts cc -- condition ) - { - set-delegate - set-condition-restarts - set-condition-continuation - } condition construct ; +C: condition ( error restarts cc -- condition ) : throw-restarts ( error restarts -- restart ) [ throw ] callcc1 2nip ; @@ -161,15 +156,14 @@ TUPLE: restart name obj continuation ; C: 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 - [ ] curry { } assoc>map - append ; + [ error>> compute-restarts ] + [ + [ restarts>> ] + [ condition-continuation [ ] curry ] bi + { } assoc>map + ] bi append ; diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 77e8f0ac05..071535a01e 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -6,7 +6,7 @@ strings io.styles vectors words system splitting math.parser 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 ; +init kernel.private libc io.encodings accessors ; IN: debugger GENERIC: error. ( error -- ) @@ -202,6 +202,12 @@ M: no-method error. M: no-math-method summary drop "No suitable arithmetic method" ; +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" ; @@ -223,9 +229,11 @@ M: slice-error error. 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" ; diff --git a/core/generic/standard/standard-docs.factor b/core/generic/standard/standard-docs.factor index 09746d35f5..1d98dec87c 100644 --- a/core/generic/standard/standard-docs.factor +++ b/core/generic/standard/standard-docs.factor @@ -11,7 +11,7 @@ HELP: standard-combination { $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:" diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index 77560c7444..b22d8818c1 100755 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -2,7 +2,8 @@ ! 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 [ heap-pop ] must-fail @@ -47,7 +48,7 @@ IN: heaps.tests : test-entry-indices ( n -- ? ) random-alist [ 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 @@ -63,9 +64,9 @@ IN: heaps.tests [ random-alist [ 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 + data>> [ [ entry-key ] map ] bi@ [ natural-sort ] bi@ ; diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index 34a4dc0d49..783d662e43 100755 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -17,10 +17,10 @@ GENERIC: heap-size ( heap -- n ) ( class -- heap ) - >r V{ } clone r> construct-delegate ; inline + >r V{ } clone r> construct-boa ; inline TUPLE: entry value key heap index ; @@ -28,11 +28,11 @@ TUPLE: entry value key heap index ; PRIVATE> -TUPLE: min-heap ; +TUPLE: min-heap < heap ; : ( -- min-heap ) min-heap ; -TUPLE: max-heap ; +TUPLE: max-heap < heap ; : ( -- max-heap ) max-heap ; @@ -40,10 +40,10 @@ INSTANCE: min-heap priority-queue 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 ; > nth-unsafe ; inline : up-value ( n heap -- entry ) >r up r> data-nth ; inline @@ -67,24 +67,24 @@ M: priority-queue heap-size ( heap -- n ) : 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 diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 61412ccf9f..c0de217bd1 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -4,7 +4,7 @@ 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 -generic.standard.engines.tuple ; +generic.standard.engines.tuple accessors ; IN: inference.backend : recursive-label ( word -- label/f ) @@ -32,18 +32,14 @@ M: word inline? : 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 - inference-error-type ; +M: inference-error compiler-error-type type>> ; : (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 + recursive-state get + \ inference-error construct-boa throw ; inline : inference-error ( ... class -- * ) +error+ (inference-error) ; inline diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 01c0a9c5f4..a4b7ad1888 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -2,7 +2,7 @@ ! 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 @@ -39,12 +39,12 @@ 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 , ; @@ -57,31 +57,27 @@ 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 ; - -: 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 ; : param-node ( param class -- node ) - { set-node-param } swap make-node ; inline + construct-empty swap >>param ; inline : in-node ( seq class -- node ) - { set-node-in-d } swap make-node ; inline + construct-empty 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 + construct-empty swap >>out-d ; inline : all-out-node ( class -- node ) flatten-meta-d swap out-node ; inline @@ -94,81 +90,81 @@ M: object flatten-curry , ; : node-child node-children first ; -TUPLE: #label word loop? ; +TUPLE: #label < node word loop? ; : #label ( word label -- node ) - \ #label param-node [ set-#label-word ] keep ; + \ #label param-node swap >>word ; 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 construct-empty ; -TUPLE: #shuffle ; +TUPLE: #shuffle < node ; -: #shuffle ( -- node ) \ #shuffle empty-node ; +: #shuffle ( -- node ) \ #shuffle construct-empty ; -TUPLE: #>r ; +TUPLE: #>r < node ; -: #>r ( -- node ) \ #>r empty-node ; +: #>r ( -- node ) \ #>r construct-empty ; -TUPLE: #r> ; +TUPLE: #r> < node ; -: #r> ( -- node ) \ #r> empty-node ; +: #r> ( -- node ) \ #r> construct-empty ; -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: #if ; +TUPLE: #branch < node ; + +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 construct-empty ; -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 [ @@ -178,17 +174,15 @@ UNION: #branch #if #dispatch ; ] 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 @@ -202,7 +196,7 @@ UNION: #branch #if #dispatch ; 2dup 2slip rot [ 2drop t ] [ - >r dup node-children swap node-successor suffix r> + >r [ children>> ] [ successor>> ] bi suffix r> [ node-exists? ] curry contains? ] if ] [ @@ -213,13 +207,13 @@ GENERIC: calls-label* ( label node -- ? ) 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 @@ -227,7 +221,7 @@ 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 [ @@ -255,54 +249,55 @@ SYMBOL: node-stack ] 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-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? @@ -317,5 +312,5 @@ UNION: #tail #! 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? ; diff --git a/core/inference/errors/errors.factor b/core/inference/errors/errors.factor index 4d57ac5883..f565420cac 100644 --- a/core/inference/errors/errors.factor +++ b/core/inference/errors/errors.factor @@ -1,15 +1,15 @@ -! 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 ; diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index 68e5920a3d..a837cfce5e 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -105,7 +105,7 @@ HELP: inference-error { $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:" + "The " { $snippet "error" } " slot contains 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 } diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 84014512aa..f688f60e56 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -8,6 +8,9 @@ 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 @@ -542,3 +545,5 @@ ERROR: custom-error ; : missing->r-check >r ; [ [ missing->r-check ] infer ] must-fail + +{ 1 0 } [ [ ] map-children ] must-infer-as diff --git a/core/io/streams/string/string-docs.factor b/core/io/streams/string/string-docs.factor index 91ac244608..5b09baa56d 100644 --- a/core/io/streams/string/string-docs.factor +++ b/core/io/streams/string/string-docs.factor @@ -13,7 +13,7 @@ ABOUT: "io.streams.string" HELP: { $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 } } diff --git a/core/listener/listener.factor b/core/listener/listener.factor index bf262b77a2..ddb29bb768 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -3,7 +3,7 @@ USING: arrays hashtables io kernel math math.parser memory namespaces parser sequences strings io.styles io.streams.duplex vectors words generic system combinators -continuations debugger definitions compiler.units ; +continuations debugger definitions compiler.units accessors ; IN: listener SYMBOL: quit-flag @@ -19,7 +19,7 @@ GENERIC: stream-read-quot ( stream -- quot/f ) : read-quot-step ( lines -- quot/f ) [ parse-lines-interactive ] [ - dup delegate unexpected-eof? + dup error>> unexpected-eof? [ 2drop f ] [ rethrow ] if ] recover ; diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 1703bea5d4..e6b7533756 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -51,7 +51,7 @@ GENERIC: optimize-node* ( node -- node/t changed? ) DEFER: optimize-nodes : optimize-children ( node -- ) - [ optimize-nodes ] change-children ; + [ optimize-nodes ] map-children ; : optimize-node ( node -- node ) dup [ diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor index df5c1e0aa4..54fca38ee2 100755 --- a/core/optimizer/def-use/def-use.factor +++ b/core/optimizer/def-use/def-use.factor @@ -100,7 +100,7 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ; 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 diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 8fcbad4d3c..7db7e46b3a 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -157,23 +157,33 @@ name>char-hook global [ [ swap tail-slice (parse-string) ] "" make swap ] change-lexer-column ; -TUPLE: parse-error file line col text ; +TUPLE: parse-error file line column line-text error ; : ( msg -- error ) - file get - lexer get [ line>> ] [ column>> ] [ line-text>> ] tri - parse-error construct-boa - [ set-delegate ] keep ; + \ parse-error construct-empty + 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 write + { + [ file>> file. ] + [ line>> number>string print ] + [ line-text>> dup string? [ print ] [ drop ] if ] + [ column>> 0 or CHAR: \s 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 ; SYMBOL: use SYMBOL: in @@ -409,6 +419,7 @@ SYMBOL: bootstrap-syntax SYMBOL: interactive-vocabs { + "accessors" "arrays" "assocs" "combinators" diff --git a/core/refs/refs-tests.factor b/core/refs/refs-tests.factor new file mode 100644 index 0000000000..1d921854e9 --- /dev/null +++ b/core/refs/refs-tests.factor @@ -0,0 +1,22 @@ +USING: refs tools.test kernel ; + +[ 3 ] [ + H{ { "a" 3 } } "a" get-ref +] unit-test + +[ 4 ] [ + 4 H{ { "a" 3 } } clone "a" + [ set-ref ] keep + get-ref +] unit-test + +[ "a" ] [ + H{ { "a" 3 } } "a" get-ref +] unit-test + +[ H{ { "b" 3 } } ] [ + "b" H{ { "a" 3 } } clone [ + "a" + set-ref + ] keep +] unit-test diff --git a/core/refs/refs.factor b/core/refs/refs.factor index c52c5daf9e..81a2338b8f 100644 --- a/core/refs/refs.factor +++ b/core/refs/refs.factor @@ -5,21 +5,18 @@ IN: refs TUPLE: ref assoc key ; -: ( assoc key class -- tuple ) - >r ref construct-boa r> construct-delegate ; inline - -: >ref< ( ref -- key assoc ) [ key>> ] [ assoc>> ] bi ; +: >ref< [ key>> ] [ assoc>> ] bi ; inline : delete-ref ( ref -- ) >ref< delete-at ; GENERIC: get-ref ( ref -- obj ) GENERIC: set-ref ( obj ref -- ) -TUPLE: key-ref ; -: ( assoc key -- ref ) key-ref ; -M: key-ref get-ref ref-key ; +TUPLE: key-ref < ref ; +C: key-ref ( assoc key -- ref ) +M: key-ref get-ref key>> ; M: key-ref set-ref >ref< rename-at ; -TUPLE: value-ref ; -: ( assoc key -- ref ) value-ref ; +TUPLE: value-ref < ref ; +C: value-ref ( assoc key -- ref ) M: value-ref get-ref >ref< at ; M: value-ref set-ref >ref< set-at ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 5df5f503f9..b385fbf369 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -4,7 +4,7 @@ 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.crc32 vocabs hashtables -graphs compiler.units io.encodings.utf8 ; +graphs compiler.units io.encodings.utf8 accessors ; IN: source-files SYMBOL: source-files diff --git a/extra/help/crossref/crossref.factor b/extra/help/crossref/crossref.factor index e347fde051..0b17461a99 100644 --- a/extra/help/crossref/crossref.factor +++ b/extra/help/crossref/crossref.factor @@ -14,7 +14,7 @@ M: link uses 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 ; diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index 06fc3c87a0..c760867d71 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -6,7 +6,8 @@ math.vectors models namespaces parser prettyprint quotations sequences sequences.lib 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 ; @@ -123,12 +124,12 @@ M: interactor stream-read-partial 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 ) From 82fc8f18db9b2b8c9e2f6eee2c2847790dbaf672 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 03:46:30 -0500 Subject: [PATCH 452/886] Converting core to use inheritance --- core/alien/arrays/arrays.factor | 2 +- core/alien/c-types/c-types.factor | 245 ++++++++++-------- core/alien/compiler/compiler.factor | 34 ++- core/classes/tuple/tuple-tests.factor | 4 +- core/compiler/tests/templates-early.factor | 8 +- core/compiler/tests/templates.factor | 44 ++++ core/cpu/architecture/architecture.factor | 2 +- core/cpu/ppc/architecture/architecture.factor | 12 +- core/cpu/x86/32/32.factor | 2 +- core/cpu/x86/64/64.factor | 8 +- core/cpu/x86/architecture/architecture.factor | 8 +- core/generator/registers/registers.factor | 55 ++-- core/kernel/kernel-docs.factor | 4 +- core/memory/memory-tests.factor | 3 +- core/optimizer/optimizer-tests.factor | 6 - core/parser/parser-tests.factor | 14 +- core/syntax/syntax-docs.factor | 4 +- core/vocabs/loader/loader-tests.factor | 4 +- core/words/words-tests.factor | 4 +- 19 files changed, 269 insertions(+), 194 deletions(-) diff --git a/core/alien/arrays/arrays.factor b/core/alien/arrays/arrays.factor index c9b9d838dd..402b01550b 100644 --- a/core/alien/arrays/arrays.factor +++ b/core/alien/arrays/arrays.factor @@ -25,7 +25,7 @@ M: array box-return drop "void*" box-return ; 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 ; diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index ca1a89b4ae..508fcd61a6 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -4,7 +4,8 @@ USING: bit-arrays byte-arrays float-arrays arrays generator.registers 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: @@ -17,8 +18,12 @@ boxer prep unboxer getter setter reg-class size align stack-align? ; +: construct-c-type ( class -- type ) + construct-empty + int-regs >>reg-class ; + : ( -- type ) - T{ int-regs } { set-c-type-reg-class } \ c-type construct ; + \ c-type construct-c-type ; SYMBOL: c-types @@ -181,10 +186,10 @@ DEFER: >c-ushort-array : 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 ; -: ( type -- type ) - long-long-type construct-delegate ; +: ( -- type ) + long-long-type construct-c-type ; M: long-long-type unbox-parameter ( n type -- ) c-type-unboxer %unbox-long-long ; @@ -235,22 +240,15 @@ M: long-long-type box-return ( type -- ) : define-from-array ( type vocab -- ) [ from-array-word ] 2keep c-array>quot define ; -: ( getter setter width boxer unboxer -- 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 @@ -264,130 +262,157 @@ M: long-long-type box-return ( type -- ) binary file-contents dup malloc-byte-array swap length ; [ - [ alien-cell ] - [ set-alien-cell ] - bootstrap-cell - "box_alien" - "alien_offset" + + [ 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" + + [ 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" + + [ 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" + + [ 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" + + [ 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" + + [ 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" + + [ 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" + + [ 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" + + [ 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" + + [ 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" + + [ 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" + + [ 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" + + [ 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 ] >>prep "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" + + [ 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 ] >>prep "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" + + [ alien-cell alien>char-string ] >>getter + [ set-alien-cell ] >>setter + bootstrap-cell >>size + bootstrap-cell >>align + "box_char_string" >>boxer + "alien_offset" >>unboxer + [ string>char-alien ] >>prep "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" + + [ alien-cell alien>u16-string ] >>getter + [ set-alien-cell ] >>setter + 4 >>size + 4 >>align + "box_u16_string" >>boxer + "alien_offset" >>unboxer + [ string>u16-alien ] >>prep "ushort*" define-primitive-type - [ string>u16-alien ] "ushort*" c-type set-c-type-prep - os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef - ] with-compilation-unit diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index ea9476a08a..0f74f52d60 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -70,29 +70,36 @@ GENERIC: reg-size ( register-class -- n ) 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? @@ -323,7 +330,7 @@ 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 ] curry + xt>> [ word-xt drop ] curry recursive-state get infer-quot ; \ alien-callback [ @@ -373,8 +380,7 @@ TUPLE: callback-context ; : wrap-callback-quot ( node -- quot ) [ - dup alien-callback-quot - swap prepare-callback-return append , + [ quot>> ] [ prepare-callback-return ] bi append , [ callback-context construct-empty do-callback ] % ] [ ] make ; @@ -395,7 +401,7 @@ TUPLE: callback-context ; callback-unwind %unwind ; : generate-callback ( node -- ) - dup alien-callback-xt dup [ + dup xt>> dup [ init-templates %save-word-xt %prologue-later diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 25d163d9cd..729997d3b2 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -218,7 +218,7 @@ C: erg's-reshape-problem [ "IN: classes.tuple.tests SYMBOL: not-a-class C: not-a-class" eval -] [ [ no-tuple-class? ] is? ] must-fail-with +] [ error>> no-tuple-class? ] must-fail-with ! Inheritance TUPLE: computer cpu ram ; @@ -488,7 +488,7 @@ USE: vocabs ] with-compilation-unit ] unit-test -[ "USE: words T{ word }" eval ] [ [ no-method? ] is? ] must-fail-with +[ "USE: words T{ word }" eval ] [ error>> no-method? ] must-fail-with ! Accessors not being forgotten... [ [ ] ] [ diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor index bdbc985078..d04f182e04 100755 --- a/core/compiler/tests/templates-early.factor +++ b/core/compiler/tests/templates-early.factor @@ -4,7 +4,7 @@ USING: compiler generator generator.registers generator.registers.private tools.test namespaces sequences words kernel math effects definitions compiler.units ; -: ( n -- vreg ) T{ int-regs } ; +: ( n -- vreg ) int-regs ; [ [ ] [ init-templates ] unit-test @@ -15,18 +15,18 @@ words kernel math effects definitions compiler.units ; [ ] [ compute-free-vregs ] unit-test - [ f ] [ 0 T{ int-regs } free-vregs member? ] unit-test + [ f ] [ 0 int-regs free-vregs member? ] unit-test [ f ] [ [ copy-templates 1 phantom-push compute-free-vregs - 1 T{ int-regs } free-vregs member? + 1 int-regs free-vregs member? ] with-scope ] unit-test - [ t ] [ 1 T{ int-regs } free-vregs member? ] unit-test + [ t ] [ 1 int-regs free-vregs member? ] unit-test ] with-scope [ diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 565c045e2a..845189ce2c 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -202,3 +202,47 @@ TUPLE: my-tuple ; ] [ 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 diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 4670cf86d2..7ea8849d30 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -6,7 +6,7 @@ byte-arrays bit-arrays float-arrays combinators words ; IN: cpu.architecture ! 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 ) diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index a1a4bd3809..bd5273efcb 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -146,11 +146,19 @@ 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 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 ( src dst 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 ; diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 4d447b38fc..699670aecd 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -155,7 +155,7 @@ M: x86.32 %box ( n reg-class func -- ) #! 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* diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index d3ccffe00e..811387675a 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -65,7 +65,7 @@ M: x86.64 %unbox ( n reg-class func -- ) over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; M: x86.64 %unbox-long-long ( n func -- ) - T{ int-regs } swap %unbox ; + int-regs swap %unbox ; M: x86.64 %unbox-struct-1 ( -- ) #! Alien must be in RDI. @@ -103,7 +103,7 @@ M: x86.64 %box ( n reg-class func -- ) f %alien-invoke ; M: x86.64 %box-long-long ( n func -- ) - T{ int-regs } swap %box ; + int-regs swap %box ; M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ; @@ -170,7 +170,7 @@ USE: cpu.x86.intrinsics ! 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 [ @@ -192,7 +192,7 @@ M: struct-type flatten-value-type ( type -- seq ) ] [ 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 ; diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index 6c9a4dc05f..25bb3c6e07 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -1,4 +1,4 @@ -! 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 @@ -22,7 +22,11 @@ M: rs-loc v>operand rs-loc-n rs-reg reg-stack ; 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 ; diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index aac1b2cdc6..a7a2c94adf 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -3,7 +3,8 @@ 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 ; +words effects alien byte-arrays bit-arrays float-arrays +accessors ; IN: generator.registers SYMBOL: +input+ @@ -13,9 +14,11 @@ SYMBOL: +clobber+ SYMBOL: known-tag ! Register classes -TUPLE: int-regs ; - -TUPLE: float-regs size ; +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 ; ( n reg-class -- vreg ) - { set-vreg-n set-delegate } vreg construct ; +C: 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 @@ -62,9 +65,9 @@ M: float-regs move-spec drop float ; M: float-regs operand-class* drop float ; ! Temporary register for stack shuffling -TUPLE: temp-reg ; +TUPLE: temp-reg reg-class>> ; -: temp-reg T{ temp-reg T{ int-regs } } ; +: temp-reg T{ temp-reg f int-regs } ; M: temp-reg move-spec drop f ; @@ -73,7 +76,7 @@ INSTANCE: temp-reg value ! A data stack location. TUPLE: ds-loc n class ; -: { set-ds-loc-n } ds-loc construct ; +: f ds-loc construct-boa ; M: ds-loc minimal-ds-loc* ds-loc-n min ; M: ds-loc operand-class* ds-loc-class ; @@ -84,8 +87,7 @@ M: ds-loc live-loc? ! A retain stack location. TUPLE: rs-loc n class ; -: { set-rs-loc-n } rs-loc construct ; - +: f rs-loc construct-boa ; M: rs-loc operand-class* rs-loc-class ; M: rs-loc set-operand-class set-rs-loc-class ; M: rs-loc live-loc? @@ -126,7 +128,7 @@ INSTANCE: cached value TUPLE: tagged vreg class ; : ( vreg -- tagged ) - { set-tagged-vreg } tagged construct ; + f tagged construct-boa ; M: tagged v>operand tagged-vreg v>operand ; M: tagged set-operand-class set-tagged-class ; @@ -340,8 +342,7 @@ SYMBOL: fresh-objects ! 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 @@ -393,7 +394,7 @@ M: value (lazy-load) : 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 ; @@ -442,7 +443,7 @@ M: loc lazy-store : fast-shuffle? ( live-locs -- ? ) #! Test if we have enough free registers to load all #! shuffle inputs at once. - T{ int-regs } free-vregs [ length ] bi@ <= ; + int-regs free-vregs [ length ] bi@ <= ; : finalize-locs ( -- ) #! Perform any deferred stack shuffling. @@ -483,8 +484,8 @@ M: loc lazy-store ! 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' ) [ length f pad-left ] keep @@ -534,7 +535,7 @@ M: loc lazy-store : 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 -- ) @@ -542,13 +543,13 @@ M: loc lazy-store : guess-vregs ( dinput rinput scratch -- int# float# ) H{ - { T{ int-regs } 0 } - { T{ float-regs 8 } 0 } + { int-regs 0 } + { double-float-regs 0 } } clone [ 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 + int-regs get double-float-regs get ] bind ; : alloc-scratch ( -- ) @@ -581,12 +582,6 @@ M: loc lazy-store 2drop t ] if ; -: class-tags ( class -- tag/f ) - class-types [ - dup num-tags get >= - [ drop object tag-number ] when - ] map prune ; - : class-tag ( class -- tag/f ) class-tags dup length 1 = [ first ] [ drop f ] if ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 328a647339..8c4c0e61c8 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -217,9 +217,7 @@ $nl { $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:" diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index 8808b30c59..0c46e307df 100755 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -1,5 +1,6 @@ USING: generic kernel kernel.private math memory prettyprint -sequences tools.test words namespaces layouts classes ; +sequences tools.test words namespaces layouts classes +classes.builtin ; IN: memory.tests TUPLE: testing x y z ; diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index aa081e8e2c..6c6adfa3e6 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -140,12 +140,6 @@ GENERIC: void-generic ( obj -- * ) [ 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 diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index ab9648c527..ab193e1c02 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -2,7 +2,7 @@ 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 classes.tuple compiler.units debugger vocabs -vocabs.loader ; +vocabs.loader accessors ; IN: parser.tests [ @@ -297,12 +297,12 @@ IN: parser.tests [ "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?" "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 ;" "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" @@ -312,7 +312,7 @@ IN: parser.tests [ "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" "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 ;" @@ -322,7 +322,7 @@ IN: parser.tests [ "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] [ [ no-word-error? ] is? ] must-fail-with + ] [ error>> error>> no-word-error? ] must-fail-with [ ] [ "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" @@ -332,12 +332,12 @@ IN: parser.tests [ "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] [ [ no-word-error? ] is? ] must-fail-with + ] [ error>> error>> no-word-error? ] must-fail-with [ "IN: parser.tests : foo ; TUPLE: foo ;" "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 diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 39a4d266e9..17dbd9f17b 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -333,8 +333,8 @@ HELP: C{ { $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." } ; diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 4b978932bc..1191594fe5 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -3,7 +3,7 @@ IN: vocabs.loader.tests USING: vocabs.loader tools.test continuations vocabs math kernel arrays sequences namespaces io.streams.string parser source-files words assocs classes.tuple definitions -debugger compiler.units tools.vocabs ; +debugger compiler.units tools.vocabs accessors ; ! This vocab should not exist, but just in case... [ ] [ @@ -68,7 +68,7 @@ IN: vocabs.loader.tests "resource:core/vocabs/loader/test/a/a.factor" parse-stream -] [ [ no-word-error? ] is? ] must-fail-with +] [ error>> error>> no-word-error? ] must-fail-with 0 "count-me" set-global diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index cef6b19943..694e54cf96 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -1,7 +1,7 @@ USING: arrays generic assocs kernel math namespaces sequences tools.test words definitions parser quotations vocabs continuations classes.tuple compiler.units -io.streams.string ; +io.streams.string accessors ; IN: words.tests [ 4 ] [ @@ -147,7 +147,7 @@ SYMBOL: quot-uses-b ] 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 From f669d2c9f18d11b6b8f7ffddd492220d5a405be4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 04:12:25 -0500 Subject: [PATCH 453/886] Fixing editors for parse-error/condition changes --- extra/editors/editors.factor | 39 ++++++++++++++++++++++++------------ 1 file changed, 26 insertions(+), 13 deletions(-) diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index e871d5f808..16de8f5eee 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -3,7 +3,7 @@ USING: parser kernel namespaces sequences definitions io.files inspector continuations tools.crossref tools.vocabs io prettyprint source-files assocs vocabs vocabs.loader -io.backend splitting classes.tuple ; +io.backend splitting accessors ; IN: editors TUPLE: no-edit-hook ; @@ -18,7 +18,7 @@ SYMBOL: 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 @@ -26,7 +26,7 @@ SYMBOL: edit-hook require ; : edit-location ( file line -- ) - >r (normalize-path) "\\\\?\\" ?head drop r> + >r (normalize-path) r> edit-hook get [ call ] [ no-edit-hook edit-location ] if* ; : edit ( defspec -- ) @@ -35,18 +35,31 @@ SYMBOL: edit-hook : 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 - 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 prefix [ - "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 ; From fe8448b4e89703982e6d05fe84beb763072b68d0 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Fri, 4 Apr 2008 11:20:10 +0200 Subject: [PATCH 454/886] Use more combinators --- extra/math/primes/primes.factor | 2 +- extra/project-euler/169/169.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/math/primes/primes.factor b/extra/math/primes/primes.factor index 685124e4e9..eeb1b66a89 100644 --- a/extra/math/primes/primes.factor +++ b/extra/math/primes/primes.factor @@ -45,7 +45,7 @@ PRIVATE> : primes-between ( low high -- seq ) primes-upto - >r 1- next-prime r> + [ 1- next-prime ] dip [ [ <=> ] binsearch ] keep [ length ] keep ; foldable : coprime? ( a b -- ? ) gcd nip 1 = ; foldable diff --git a/extra/project-euler/169/169.factor b/extra/project-euler/169/169.factor index 61645bf50b..35fb2c2c1e 100644 --- a/extra/project-euler/169/169.factor +++ b/extra/project-euler/169/169.factor @@ -30,7 +30,7 @@ MEMO: fn ( n -- x ) { { [ dup 2 < ] [ drop 1 ] } { [ dup odd? ] [ 2/ fn ] } - { [ t ] [ 2/ [ fn ] keep 1- fn + ] } + { [ t ] [ 2/ [ fn ] [ 1- fn + ] bi ] } } cond ; : euler169 ( -- result ) From b040d4d033442061d640c2866e90d53c55315a5f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 04:33:35 -0500 Subject: [PATCH 455/886] Convert prettyprinter to inheritance --- core/classes/tuple/tuple-docs.factor | 2 +- core/prettyprint/prettyprint-docs.factor | 6 +- .../prettyprint/sections/sections-docs.factor | 14 +-- core/prettyprint/sections/sections.factor | 118 +++++++++--------- 4 files changed, 70 insertions(+), 70 deletions(-) diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 0abfb8851f..3e1f85c936 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -269,7 +269,7 @@ $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." } ; +{ $description "Pushes a sequence of tuple slot values, not including the tuple class word." } ; { tuple-slots tuple>array } related-words diff --git a/core/prettyprint/prettyprint-docs.factor b/core/prettyprint/prettyprint-docs.factor index 7ea0f5c412..2b294115be 100755 --- a/core/prettyprint/prettyprint-docs.factor +++ b/core/prettyprint/prettyprint-docs.factor @@ -48,7 +48,7 @@ ARTICLE: "prettyprint-limitations" "Prettyprinter limitations" "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? } @@ -60,8 +60,8 @@ $nl { $subsection short-section } { $subsection long-section } "Utilities to use when implementing sections:" -{ $subsection
} -{ $subsection delegate>block } +{ $subsection construct-section } +{ $subsection construct-block } { $subsection add-section } ; ARTICLE: "prettyprint-sections" "Prettyprinter sections" diff --git a/core/prettyprint/sections/sections-docs.factor b/core/prettyprint/sections/sections-docs.factor index 9833a7e50a..e704df2085 100755 --- a/core/prettyprint/sections/sections-docs.factor +++ b/core/prettyprint/sections/sections-docs.factor @@ -67,7 +67,7 @@ HELP: short-section? { $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 } @@ -78,12 +78,12 @@ HELP: section } "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:
diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor index 9574d18eb1..c5b26ca837 100644 --- a/core/prettyprint/sections/sections.factor +++ b/core/prettyprint/sections/sections.factor @@ -1,9 +1,9 @@ -! 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 namespaces sequences strings io.styles vectors words prettyprint.config splitting classes continuations -io.streams.nested ; +io.streams.nested accessors ; IN: prettyprint.sections ! State @@ -70,17 +70,15 @@ start end start-group? end-group? style overhang ; -:
( style length -- section ) - position [ dup rot + dup ] change 0 { - set-section-style - set-section-start - set-section-end - set-section-overhang - } section construct ; +: construct-section ( length class -- section ) + construct-empty + 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>> last-newline get - ] [ overhang>> ] bi + text-fits? ; M: section indent-section? drop f ; @@ -98,10 +96,10 @@ M: object short-section? section-fits? ; : indent> ( section -- ) tab-size get neg change-indent ; : > fresh-line ; : fresh-line> ( section -- ) - dup newline-after? [ section-end fresh-line ] [ drop ] if ; + dup newline-after? [ end>> fresh-line ] [ drop ] if ; : ( type -- section ) - H{ } 0
- { set-line-break-type set-delegate } - \ line-break construct ; + 0 \ line-break construct-section + swap >>type ; M: line-break short-section drop ; M: line-break long-section drop ; ! Block sections -TUPLE: block sections ; +TUPLE: block < section sections ; + +: construct-block ( style class -- block ) + 0 swap construct-section + V{ } clone >>sections + swap >>style ; inline : ( style -- block ) - 0
V{ } clone - { set-delegate set-block-sections } block construct ; - -: delegate>block ( obj -- ) H{ } swap set-delegate ; + block construct-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>> last-newline get = not ] + [ short-section? ] bi + and [ bl ] when ; : line-break ( type -- ) [ 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 @@ -179,28 +178,28 @@ M: block short-section ( block -- ) [ advance ] pprint-sections ; : do-break ( break -- ) - dup line-break-type hard eq? + dup type>> hard eq? over section-end last-newline get - margin get 2/ > or [ > empty? ; : if-nonempty ( block quot -- ) >r dup empty-block? [ drop ] r> if ; inline : ( ( ( ( ( string style -- text ) - over length 1+
- { set-text-string set-delegate } - \ text construct ; + over length 1+ \ text construct-section + swap >>style + swap >>string ; M: text short-section text-string write ; @@ -211,18 +210,18 @@ M: text long-section short-section ; : text ( string -- ) H{ } styled-text ; ! Inset section -TUPLE: inset narrow? ; +TUPLE: inset < block narrow? ; : ( narrow? -- block ) - 2 H{ } - { set-inset-narrow? set-section-overhang set-delegate } - inset construct ; + H{ } inset construct-block + 2 >>overhang + swap >>narrow? ; M: inset long-section - dup inset-narrow? [ + dup narrow?>> [ [ ( ( -- block ) - H{ } flow construct-delegate ; + H{ } flow construct-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 ; : ( ( -- block ) - H{ } colon construct-delegate ; + H{ } colon construct-block ; M: colon long-section short-section ; @@ -261,11 +261,11 @@ M: colon unindent-first-line? drop t ; : (>end drop ; : block> ( -- ) pprinter-stack get pop - [ dup save-end-position add-section ] if-nonempty ; + [ [ save-end-position ] [ add-section ] bi ] if-nonempty ; : with-section-state ( quot -- ) [ @@ -278,7 +278,7 @@ M: colon unindent-first-line? drop t ; : do-pprint ( block -- ) [ [ - dup section-style [ + dup style>> [ [ end-printing set dup short-section ] callcc0 ] with-nesting drop ] if-nonempty @@ -298,9 +298,9 @@ M: f section-start-group? drop t ; 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 ; @@ -315,19 +315,19 @@ M: f section-end-group? drop f ; ] { } 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 > chop-break group-flow [ dup ?break-group [ dup line-break? [ do-break ] [ - dup advance pprint-section + [ advance ] [ pprint-section ] bi ] if ] each ] each From f2cbd7648f19ccc98e923083a3aef2c43abfc5c9 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Fri, 4 Apr 2008 11:40:49 +0200 Subject: [PATCH 456/886] Use more combinators --- extra/lazy-lists/lazy-lists.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index f642d8881c..19dc8a186b 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -78,7 +78,7 @@ M: lazy-cons nil? ( lazy-cons -- bool ) 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) ; @@ -273,7 +273,7 @@ M: lazy-from-by car ( lazy-from-by -- car ) 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 ; @@ -370,10 +370,10 @@ M: lazy-concat nil? ( lazy-concat -- bool ) ] 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 @@ -382,7 +382,7 @@ DEFER: lmerge [ dup [ car ] curry -rot [ - >r cdr r> cdr lmerge + [ cdr ] bi lmerge ] 2curry lazy-cons ] 2curry lazy-cons ; @@ -419,7 +419,7 @@ M: lazy-io cdr ( lazy-io -- cdr ) [ lazy-io-stream ] keep [ lazy-io-quot ] keep car [ - >r f f r> [ swap set-lazy-io-cdr ] keep + [ f f ] dip [ swap set-lazy-io-cdr ] keep ] [ 3drop nil ] if From 9e227d394e531921574797e5be5398c58f190da4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 05:09:58 -0500 Subject: [PATCH 457/886] Remove redundant code --- core/classes/tuple/tuple.factor | 4 ---- core/kernel/kernel.factor | 4 ---- 2 files changed, 8 deletions(-) diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index ef81a0c953..546f7b15e8 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -7,10 +7,6 @@ classes classes.private slots.deprecated slots.private slots compiler.units math.private accessors assocs ; IN: classes.tuple -M: tuple delegate 2 slot ; - -M: tuple set-delegate 2 set-slot ; - M: tuple class 1 slot 2 slot { word } declare ; ERROR: no-tuple-class class ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 1935c89431..2b1dd3cf9c 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -194,12 +194,8 @@ M: callstack clone (clone) ; PRIVATE> ! Deprecated -GENERIC: delegate ( obj -- delegate ) - M: object delegate drop f ; -GENERIC: set-delegate ( delegate tuple -- ) - GENERIC# get-slots 1 ( tuple slots -- ... ) GENERIC# set-slots 1 ( ... tuple slots -- ) From 48a6baedcd8b6978186e90016833a5797830d24f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 05:44:45 -0500 Subject: [PATCH 458/886] Convert compiler to use inheritance --- core/compiler/tests/templates-early.factor | 4 +- core/generator/registers/registers.factor | 142 ++++++++++----------- 2 files changed, 70 insertions(+), 76 deletions(-) diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor index d04f182e04..71da9436f1 100755 --- a/core/compiler/tests/templates-early.factor +++ b/core/compiler/tests/templates-early.factor @@ -173,12 +173,12 @@ SYMBOL: template-chosen ] 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 [ cached? ] all? ] unit-test ! >r diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index a7a2c94adf..b5b3f0b2c0 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -230,48 +230,44 @@ INSTANCE: constant value } case ; ! A compile-time stack -TUPLE: phantom-stack height ; +TUPLE: phantom-stack height stack ; + +M: phantom-stack clone + call-next-method [ clone ] change-stack ; GENERIC: finalize-height ( stack -- ) -SYMBOL: phantom-d -SYMBOL: phantom-r - -: ( class -- stack ) - >r - V{ } clone 0 - { set-delegate set-phantom-stack-height } - phantom-stack construct - r> construct-delegate ; +: construct-phantom-stack ( class -- stack ) + >r 0 V{ } clone r> construct-boa ; inline : (loc) #! Utility for methods on - 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: ( n stack -- loc ) -TUPLE: phantom-datastack ; +TUPLE: phantom-datastack < phantom-stack ; -: phantom-datastack ; +: ( -- stack ) + phantom-datastack construct-phantom-stack ; M: phantom-datastack (loc) ; M: phantom-datastack finalize-height \ %inc-d (finalize-height) ; -TUPLE: phantom-retainstack ; +TUPLE: phantom-retainstack < phantom-stack ; -: phantom-retainstack ; +: ( -- stack ) + phantom-retainstack construct-phantom-stack ; M: phantom-retainstack (loc) ; @@ -283,34 +279,33 @@ M: phantom-retainstack finalize-height >r r> [ ] 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 ) @@ -318,18 +313,16 @@ M: phantom-stack cut-phantom 2dup cut-phantom >r >r neg r> adjust-phantom r> ; -: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ; - : 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 2array flip [ live-loc? ] assoc-subset values ; @@ -349,7 +342,7 @@ SYMBOL: fresh-objects \ free-vregs get at ; : alloc-vreg ( spec -- reg ) - dup reg-spec>class free-vregs pop swap { + [ reg-spec>class free-vregs pop ] keep { { f [ ] } { unboxed-alien [ ] } { unboxed-byte-array [ ] } @@ -375,8 +368,8 @@ SYMBOL: fresh-objects } 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 [ @@ -419,7 +412,7 @@ M: loc lazy-store #! 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 @@ -463,13 +456,13 @@ M: loc lazy-store #! 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 ; @@ -488,6 +481,7 @@ M: loc lazy-store >r int-regs free-vregs length <= r> and ; : phantom&spec ( phantom spec -- phantom' spec' ) + >r stack>> r> [ length f pad-left ] keep [ ] bi@ ; inline @@ -505,7 +499,7 @@ M: loc lazy-store : 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 ; @@ -517,14 +511,15 @@ M: loc lazy-store 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 ] bi@ ; : clash? ( seq -- ? ) - phantoms append [ + phantoms [ stack>> ] bi@ append [ dup cached? [ cached-vreg ] when swap member? ] with contains? ; @@ -542,15 +537,14 @@ M: loc lazy-store [ first reg-spec>class ] map count-vregs ; : guess-vregs ( dinput rinput scratch -- int# float# ) - H{ - { int-regs 0 } - { double-float-regs 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 + phantom-retainstack get swap count-input-vregs + phantom-datastack get swap count-input-vregs int-regs get double-float-regs get - ] bind ; + ] with-scope ; : alloc-scratch ( -- ) +scratch+ get [ >r alloc-vreg r> set ] assoc-each ; @@ -567,7 +561,7 @@ M: loc lazy-store 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 @@ -597,7 +591,7 @@ M: loc lazy-store >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 ( -- ) @@ -606,14 +600,14 @@ M: loc lazy-store ] 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 @@ -622,7 +616,7 @@ PRIVATE> 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 [ @@ -642,16 +636,16 @@ PRIVATE> : init-templates ( -- ) #! Initialize register allocator. V{ } clone fresh-objects set - phantom-d set - phantom-r set + phantom-datastack set + 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 ) @@ -667,17 +661,17 @@ UNION: immediate fixnum POSTPONE: 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 ; From dcc28cd0f837f18b447d887fa3c5d75e45416cf7 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Fri, 4 Apr 2008 12:48:36 +0200 Subject: [PATCH 459/886] Fix bug in project-euler.169 introduced by a former checkin --- extra/project-euler/169/169.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/169/169.factor b/extra/project-euler/169/169.factor index 35fb2c2c1e..90655149dc 100644 --- a/extra/project-euler/169/169.factor +++ b/extra/project-euler/169/169.factor @@ -30,7 +30,7 @@ MEMO: fn ( n -- x ) { { [ dup 2 < ] [ drop 1 ] } { [ dup odd? ] [ 2/ fn ] } - { [ t ] [ 2/ [ fn ] [ 1- fn + ] bi ] } + { [ t ] [ 2/ [ fn ] [ 1- fn + ] bi + ] } } cond ; : euler169 ( -- result ) From cf5ff72eb96d4e390754e084466cc86a74f4640a Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Fri, 4 Apr 2008 12:51:05 +0200 Subject: [PATCH 460/886] Fix bug introduced by former checkin --- extra/lazy-lists/lazy-lists.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index 19dc8a186b..d13848498f 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -382,7 +382,7 @@ DEFER: lmerge [ dup [ car ] curry -rot [ - [ cdr ] bi lmerge + [ cdr ] bi@ lmerge ] 2curry lazy-cons ] 2curry lazy-cons ; From 6b626f108c94057d6066173ad34399b87227ac8c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 05:57:59 -0500 Subject: [PATCH 461/886] Update extra/delegate; removing section protocol since it makes little sense --- extra/delegate/protocols/protocols.factor | 7 ------- 1 file changed, 7 deletions(-) diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor index f9b4c8648d..ce03b3b205 100755 --- a/extra/delegate/protocols/protocols.factor +++ b/extra/delegate/protocols/protocols.factor @@ -23,10 +23,3 @@ PROTOCOL: stream-protocol PROTOCOL: definition-protocol where set-where forget uses redefined* synopsis* definer definition ; - -PROTOCOL: prettyprint-section-protocol - section-fits? indent-section? unindent-first-line? - newline-after? short-section? short-section long-section -
delegate>block add-section ; - - From 5cc78f5b3900651754a12718352ce532afd5eea4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 06:21:50 -0500 Subject: [PATCH 462/886] Remove usages of delegation from core io --- core/io/streams/duplex/duplex-docs.factor | 2 +- core/io/streams/nested/nested.factor | 67 ++++++++++------ core/io/streams/plain/plain.factor | 2 +- .../prettyprint/sections/sections-docs.factor | 2 +- core/prettyprint/sections/sections.factor | 80 +++++++++---------- 5 files changed, 86 insertions(+), 67 deletions(-) diff --git a/core/io/streams/duplex/duplex-docs.factor b/core/io/streams/duplex/duplex-docs.factor index fa82c54163..6a956c6694 100755 --- a/core/io/streams/duplex/duplex-docs.factor +++ b/core/io/streams/duplex/duplex-docs.factor @@ -10,7 +10,7 @@ ARTICLE: "io.streams.duplex" "Duplex streams" 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: { $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } } diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor index e32c90a2fc..6a8a09fbdb 100755 --- a/core/io/streams/nested/nested.factor +++ b/core/io/streams/nested/nested.factor @@ -1,30 +1,57 @@ ! 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 ; +IN: io.streams.nested -TUPLE: ignore-close-stream ; +TUPLE: filter-writer stream ; -: ignore-close-stream construct-delegate ; +M: filter-writer stream-format + stream>> stream-format ; -M: ignore-close-stream dispose drop ; +M: filter-writer stream-write + stream>> stream-write ; -TUPLE: style-stream style ; +M: filter-writer stream-write1 + stream>> stream-write1 ; -: do-nested-style ( style stream -- style delegate ) - [ style-stream-style swap union ] keep - delegate ; inline +M: filter-writer make-span-stream + stream>> make-span-stream ; -: ( style delegate -- stream ) - { set-style-stream-style set-delegate } - style-stream construct ; +M: filter-writer make-block-stream + stream>> make-block-stream ; + +M: filter-writer make-cell-stream + stream>> make-cell-stream ; + +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 + drop ; + +TUPLE: ignore-close-stream < filter-writer ; + +C: ignore-close-stream + +TUPLE: style-stream < filter-writer style ; + +: do-nested-style ( style style-stream -- style stream ) + [ style>> swap union ] [ stream>> ] bi ; inline + +C: 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 ; @@ -33,15 +60,9 @@ M: style-stream make-span-stream do-nested-style make-span-stream ; M: style-stream make-block-stream - [ do-nested-style make-block-stream ] keep - style-stream-style swap ; + [ do-nested-style make-block-stream ] [ style>> ] bi + ; M: style-stream make-cell-stream - [ do-nested-style make-cell-stream ] keep - style-stream-style swap ; - -TUPLE: block-stream ; - -: block-stream construct-delegate ; - -M: block-stream dispose drop ; + [ do-nested-style make-cell-stream ] [ style>> ] bi + ; diff --git a/core/io/streams/plain/plain.factor b/core/io/streams/plain/plain.factor index 4898a58fb1..8d8a0a8810 100644 --- a/core/io/streams/plain/plain.factor +++ b/core/io/streams/plain/plain.factor @@ -12,7 +12,7 @@ M: plain-writer stream-format nip stream-write ; M: plain-writer make-span-stream - ; + swap ; M: plain-writer make-block-stream nip ; diff --git a/core/prettyprint/sections/sections-docs.factor b/core/prettyprint/sections/sections-docs.factor index e704df2085..3a86c014af 100755 --- a/core/prettyprint/sections/sections-docs.factor +++ b/core/prettyprint/sections/sections-docs.factor @@ -86,7 +86,7 @@ HELP: section { { $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:
+HELP: construct-section { $values { "style" hashtable } { "length" integer } { "section" section } } { $description "Creates a new section with the given length starting from " { $link position } ", advancing " { $link position } "." } ; diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor index c5b26ca837..848947e624 100644 --- a/core/prettyprint/sections/sections.factor +++ b/core/prettyprint/sections/sections.factor @@ -11,37 +11,38 @@ SYMBOL: position 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 ) 0 1 f 0 pprinter construct-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 write ; +: do-indent ( -- ) pprinter get indent>> CHAR: \s 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 @@ -78,7 +79,9 @@ style overhang ; 0 >>overhang ; inline M: section section-fits? ( section -- ? ) - [ end>> last-newline get - ] [ overhang>> ] bi + text-fits? ; + [ end>> pprinter get last-newline>> - ] + [ overhang>> ] bi + + text-fits? ; M: section indent-section? drop f ; @@ -88,12 +91,14 @@ M: section newline-after? 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 ; -: ( section -- ) tab-size get neg change-indent ; +: indent> ( section -- ) tab-size get neg indent+ ; : > fresh-line ; @@ -108,17 +113,14 @@ M: object short-section? section-fits? ; : long-section> ( section -- ) dup indent> fresh-line> ; -: with-style* ( style quot -- ) - swap stdio [ ] 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 + [ ] + tri ] if ; ! Break section @@ -159,7 +161,7 @@ TUPLE: block < section sections ; last-section t >>end-group? drop ; : advance ( section -- ) - [ start>> last-newline get = not ] + [ start>> pprinter get last-newline>> = not ] [ short-section? ] bi and [ bl ] when ; @@ -178,9 +180,10 @@ M: block short-section ( block -- ) [ advance ] pprint-sections ; : do-break ( break -- ) - dup type>> hard eq? - over section-end last-newline get - margin get 2/ > or - [ > hard eq? ] + [ end>> pprinter get last-newline>> - margin get 2/ > ] tri + or [ > empty? ; @@ -267,22 +270,17 @@ M: colon unindent-first-line? drop t ; pprinter-stack get pop [ [ save-end-position ] [ add-section ] bi ] if-nonempty ; -: with-section-state ( quot -- ) - [ - 0 indent set - 0 last-newline set - 1 line-count set - call - ] with-scope ; inline - : do-pprint ( block -- ) - [ + pprinter [ [ dup style>> [ - [ end-printing set dup short-section ] callcc0 - ] with-nesting drop + [ + >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 ) From c8588a37ee08f2c2fc90a0883f2931363ffc0d7a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 06:28:51 -0500 Subject: [PATCH 463/886] Load fixes --- core/prettyprint/config/config-docs.factor | 6 ------ core/prettyprint/sections/sections-docs.factor | 13 ------------- 2 files changed, 19 deletions(-) diff --git a/core/prettyprint/config/config-docs.factor b/core/prettyprint/config/config-docs.factor index f197ac7966..1a2fd69949 100644 --- a/core/prettyprint/config/config-docs.factor +++ b/core/prettyprint/config/config-docs.factor @@ -4,12 +4,6 @@ IN: prettyprint.config 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." } ; diff --git a/core/prettyprint/sections/sections-docs.factor b/core/prettyprint/sections/sections-docs.factor index 3a86c014af..b07e83d0d1 100755 --- a/core/prettyprint/sections/sections-docs.factor +++ b/core/prettyprint/sections/sections-docs.factor @@ -5,18 +5,9 @@ strings definitions ; 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." } ; @@ -90,10 +81,6 @@ HELP: construct-section { $values { "style" hashtable } { "length" integer } { "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: Date: Fri, 4 Apr 2008 07:08:03 -0500 Subject: [PATCH 464/886] Fix amazing performance regression --- core/definitions/definitions-docs.factor | 7 ------- core/definitions/definitions.factor | 7 ------- core/words/words.factor | 24 ++++++++++++++++++++++-- vm/types.c | 2 +- 4 files changed, 23 insertions(+), 17 deletions(-) diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index d855a14be9..d43c61ff70 100755 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -12,8 +12,6 @@ $nl { $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 } @@ -108,11 +106,6 @@ HELP: usage { $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." } diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index cec5109909..6ee21fc016 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -42,13 +42,6 @@ M: object uses drop f ; : 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 ; diff --git a/core/words/words.factor b/core/words/words.factor index 059815e952..2510c50347 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -121,8 +121,28 @@ SYMBOL: +called+ compiled-usage [ nip +inlined+ eq? ] assoc-subset update ] with each keys ; -M: word redefined* ( word -- ) - { "inferred-effect" "no-effect" } reset-props ; + + +: redefined ( word -- ) + H{ } clone visited [ (redefined) ] with-variable ; SYMBOL: changed-words diff --git a/vm/types.c b/vm/types.c index 24bb4cb3ca..f88c3ef3cb 100755 --- a/vm/types.c +++ b/vm/types.c @@ -42,7 +42,7 @@ F_WORD *allot_word(CELL vocab, CELL name) 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]; From 9c31dc1164796afaad34a3bb966ace3dcf9b7608 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 07:39:00 -0500 Subject: [PATCH 465/886] Fix failing unit test --- core/io/files/files-tests.factor | 6 +++--- core/io/streams/nested/nested.factor | 6 +++++- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index b4a7d44433..5efbb9496d 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,7 +1,7 @@ IN: io.files.tests -USING: tools.test io.files io threads kernel continuations -io.encodings.ascii io.files.unique sequences strings accessors -io.encodings.utf8 ; +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 diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor index 6a8a09fbdb..2a522d8e36 100755 --- a/core/io/streams/nested/nested.factor +++ b/core/io/streams/nested/nested.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic assocs kernel namespaces strings -quotations io continuations accessors ; +quotations io continuations accessors sequences ; IN: io.streams.nested TUPLE: filter-writer stream ; @@ -66,3 +66,7 @@ M: style-stream make-block-stream M: style-stream make-cell-stream [ do-nested-style make-cell-stream ] [ style>> ] bi ; + +M: style-stream stream-write-table + [ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri* + stream-write-table ; From 7e7ba4ca383a024efd798681131fd121a5661932 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 07:39:09 -0500 Subject: [PATCH 466/886] Fixing streams --- extra/ui/gadgets/panes/panes.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 91b7f0f225..94ff427961 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -166,7 +166,7 @@ M: pane-stream dispose drop ; M: pane-stream stream-flush drop ; M: pane-stream make-span-stream - ; + swap ; ! Character styles From fa65bdad14c89d0072f0a02d2ab5cfad9f940e9c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 07:40:36 -0500 Subject: [PATCH 467/886] Fix load failures --- extra/hardware-info/windows/ce/ce.factor | 2 +- extra/random-tester/safe-words/safe-words.factor | 6 ------ 2 files changed, 1 insertion(+), 7 deletions(-) diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor index 55c2ac6c0d..c61a3c8b8a 100755 --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/hardware-info/windows/ce/ce.factor @@ -1,5 +1,5 @@ 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 : memory-status ( -- MEMORYSTATUS ) diff --git a/extra/random-tester/safe-words/safe-words.factor b/extra/random-tester/safe-words/safe-words.factor index f7eac4c32d..5ca2c79afe 100755 --- a/extra/random-tester/safe-words/safe-words.factor +++ b/extra/random-tester/safe-words/safe-words.factor @@ -52,11 +52,6 @@ IN: random-tester.safe-words >r r> } ; -: method-words - { - forget-word - } ; - : stateful-words { counter @@ -82,7 +77,6 @@ IN: random-tester.safe-words bignum-words % initialization-words % stack-words % - method-words % stateful-words % exit-words % foo-words % From a4700e072e06f3373e3e9d02cd9c9af9127df098 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 01:56:37 +1300 Subject: [PATCH 468/886] delocalise apply-rule --- extra/peg/peg.factor | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 217805ce47..e9f1d05473 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -188,16 +188,12 @@ C: peg-head m ans>> ] if ; -:: apply-rule ( r p -- ast ) - [let* | - m [ r p recall ] - | - m [ - r m apply-memo-rule - ] [ - r p apply-non-memo-rule - ] if - ] ; inline +: 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. From 72dbac6a2900617818a41d726e2016f3b3b810bb Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 02:07:17 +1300 Subject: [PATCH 469/886] delocalise apply-memo-rule --- extra/peg/peg.factor | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index e9f1d05473..b157580f9b 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -179,14 +179,13 @@ C: peg-head ] if ] ; inline -:: apply-memo-rule ( r m -- ast ) - m pos>> pos set - m ans>> left-recursion? [ - r m ans>> setup-lr - m ans>> seed>> +: apply-memo-rule ( r m -- ast ) + [ ans>> ] [ pos>> ] bi pos set + dup left-recursion? [ + [ setup-lr ] keep seed>> ] [ - m ans>> - ] if ; + nip + ] if ; inline : apply-rule ( r p -- ast ) 2dup recall [ From a6b160c447445461a96c973b7d5e6031ff189c03 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 02:26:41 +1300 Subject: [PATCH 470/886] apply-memo-rule doesn't need to be inline --- extra/peg/peg.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index b157580f9b..3828fe7d9e 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -185,7 +185,7 @@ C: peg-head [ setup-lr ] keep seed>> ] [ nip - ] if ; inline + ] if ; : apply-rule ( r p -- ast ) 2dup recall [ From ca652dc1573acfbfaeb8244d1cb0791ac6a36516 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 08:44:32 -0500 Subject: [PATCH 471/886] Fix UI panes --- core/io/streams/nested/nested.factor | 4 +- core/io/streams/plain/plain.factor | 2 +- extra/ui/gadgets/panes/panes-tests.factor | 73 ++++++++++++++++++++--- extra/ui/gadgets/panes/panes.factor | 2 +- 4 files changed, 71 insertions(+), 10 deletions(-) diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor index 2a522d8e36..6b8953f86e 100755 --- a/core/io/streams/nested/nested.factor +++ b/core/io/streams/nested/nested.factor @@ -34,10 +34,12 @@ M: filter-writer stream-write-table stream>> stream-write-table ; M: filter-writer dispose - drop ; + stream>> dispose ; TUPLE: ignore-close-stream < filter-writer ; +M: ignore-close-stream dispose drop ; + C: ignore-close-stream TUPLE: style-stream < filter-writer style ; diff --git a/core/io/streams/plain/plain.factor b/core/io/streams/plain/plain.factor index 8d8a0a8810..47bff681cd 100644 --- a/core/io/streams/plain/plain.factor +++ b/core/io/streams/plain/plain.factor @@ -12,7 +12,7 @@ M: plain-writer stream-format nip stream-write ; M: plain-writer make-span-stream - swap ; + swap ; M: plain-writer make-block-stream nip ; diff --git a/extra/ui/gadgets/panes/panes-tests.factor b/extra/ui/gadgets/panes/panes-tests.factor index e3f6e36050..0263b15d71 100755 --- a/extra/ui/gadgets/panes/panes-tests.factor +++ b/extra/ui/gadgets/panes/panes-tests.factor @@ -1,8 +1,8 @@ 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 ; @@ -17,20 +17,79 @@ tools.test.ui models ; [ 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 [ \ = see ] with-pane [ \ = help ] with-pane diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 94ff427961..fedacbd2af 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -166,7 +166,7 @@ M: pane-stream dispose drop ; M: pane-stream stream-flush drop ; M: pane-stream make-span-stream - swap ; + swap ; ! Character styles From 5b5aaa344a574b92f0776a0403874e761758bfb1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 09:17:26 -0500 Subject: [PATCH 472/886] Smarter fep --- vm/debug.c | 34 ++++++++++++++++++++++++++++++++-- 1 file changed, 32 insertions(+), 2 deletions(-) diff --git a/vm/debug.c b/vm/debug.c index 7e18738afc..101313a5ee 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -146,6 +146,18 @@ void print_objects(CELL start, CELL end) } } +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)); @@ -158,6 +170,7 @@ void print_stack_frame(F_STACK_FRAME *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); @@ -336,6 +349,8 @@ void factorbug(void) printf("push -- push object on data stack - NOT SAFE\n"); printf("code -- code heap dump\n"); + bool seen_command = false; + for(;;) { char cmd[1024]; @@ -344,7 +359,22 @@ void factorbug(void) 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) { @@ -371,9 +401,9 @@ void factorbug(void) 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) From 41e5226df6c9777e2defd5921d9b34f3259a678d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 09:17:33 -0500 Subject: [PATCH 473/886] Load fixes --- extra/contributors/contributors.factor | 5 +++-- extra/delegate/protocols/protocols.factor | 2 +- extra/pack/pack.factor | 7 +++---- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/contributors/contributors.factor b/extra/contributors/contributors.factor index 6365b91517..d0da724cc6 100755 --- a/extra/contributors/contributors.factor +++ b/extra/contributors/contributors.factor @@ -5,8 +5,9 @@ sequences sequences.lib assocs system sorting math.parser ; IN: contributors : changelog ( -- authors ) - image parent-directory cd - "git-log --pretty=format:%an" lines ; + image parent-directory [ + "git-log --pretty=format:%an" lines + ] with-directory ; : patch-counts ( authors -- assoc ) dup prune diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor index ce03b3b205..64e133dd2a 100755 --- a/extra/delegate/protocols/protocols.factor +++ b/extra/delegate/protocols/protocols.factor @@ -21,5 +21,5 @@ PROTOCOL: stream-protocol make-cell-stream stream-write-table ; PROTOCOL: definition-protocol - where set-where forget uses redefined* + where set-where forget uses synopsis* definer definition ; diff --git a/extra/pack/pack.factor b/extra/pack/pack.factor index f5ba0fd11d..65912244dd 100755 --- a/extra/pack/pack.factor +++ b/extra/pack/pack.factor @@ -1,8 +1,7 @@ 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 From 8f8d78d73d209f01bd1a4baab5ef32275ca85762 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 09:57:06 -0500 Subject: [PATCH 474/886] Documentation updates --- core/classes/tuple/tuple-docs.factor | 22 ++++++++++++++++ core/continuations/continuations-docs.factor | 27 +++++++++++++++++--- core/kernel/kernel-docs.factor | 1 + core/syntax/syntax-docs.factor | 14 +++++++--- 4 files changed, 58 insertions(+), 6 deletions(-) diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 3e1f85c936..4ee72cdf83 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -219,6 +219,26 @@ ARTICLE: "tuple-examples" "Tuple examples" } "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" } @@ -234,6 +254,8 @@ $nl { $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" diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index ca7af930f2..b3adb1b165 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -1,6 +1,6 @@ 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" @@ -17,6 +17,25 @@ ARTICLE: "errors-post-mortem" "Post-mortem error inspection" { $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 + " ... 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 @@ -27,10 +46,13 @@ $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 } ; @@ -61,8 +83,7 @@ $nl "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" diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 6a2a2ff917..4578e2a93f 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -278,6 +278,7 @@ ARTICLE: "dataflow" "Data and control flow" { $subsection "combinators" } "Advanced topics:" { $subsection "implementing-combinators" } +{ $subsection "errors" } { $subsection "continuations" } ; ABOUT: "dataflow" diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 17dbd9f17b..61e77ae9a5 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -565,9 +565,17 @@ HELP: 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. Defines a new word " { $snippet "class?" } " that boa-constructs this tuple and throws it." } ; - -{ POSTPONE: ERROR: POSTPONE: TUPLE: } related-words +{ $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 construct-boa throw ;" + } +} ; HELP: C: { $syntax "C: constructor class" } From 0cc26425fd03b10b812e4461a671cfec4ba13106 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 10:05:52 -0500 Subject: [PATCH 475/886] Make image smaller on Windows --- extra/tools/deploy/shaker/shaker.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index ee9c2b9fab..ca421ecff8 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -186,6 +186,11 @@ IN: tools.deploy.shaker deploy-ui? get [ "ui-error-hook" "ui.gadgets.worlds" lookup , ] when + + "" "inference.dataflow" lookup [ , ] when* + + "windows-messages" "windows.messages" lookup [ , ] when* + ] { } make ; : strip-globals ( stripped-globals -- ) From f6030fb3a4976139893d0ff55c04bd2e42449c3b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 10:11:31 -0500 Subject: [PATCH 476/886] Another improvement --- extra/tools/deploy/shaker/shaker.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index ca421ecff8..72e1c33a26 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -6,6 +6,7 @@ memory kernel.private continuations io prettyprint vocabs.loader debugger system strings ; QUALIFIED: bootstrap.stage2 QUALIFIED: classes +QUALIFIED: command-line QUALIFIED: compiler.errors.private QUALIFIED: compiler.units QUALIFIED: continuations @@ -139,14 +140,17 @@ IN: tools.deploy.shaker { } { "cpu" } strip-vocab-globals % { + 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 @@ -187,7 +191,7 @@ IN: tools.deploy.shaker "ui-error-hook" "ui.gadgets.worlds" lookup , ] when - "" "inference.dataflow" lookup [ , ] when* + "" "inference.dataflow" lookup [ , ] when* "windows-messages" "windows.messages" lookup [ , ] when* From 87a705e782cbefb6c2034799605f30ed638401b5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 4 Apr 2008 12:02:12 -0500 Subject: [PATCH 477/886] fix sha1-interleave --- extra/crypto/sha1/sha1.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index d054eda31b..37e92db60f 100755 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -125,4 +125,4 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; [ zero? ] left-trim dup length odd? [ 1 tail ] when seq>2seq [ byte-array>sha1 ] bi@ - swap 2seq>seq ; + 2seq>seq ; From b35ef018600eb8cd681e8e5520c3896014613658 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 4 Apr 2008 12:02:25 -0500 Subject: [PATCH 478/886] fix windows bootstrap --- extra/io/windows/launcher/launcher.factor | 9 +++++---- extra/io/windows/windows.factor | 11 ++++++----- 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index f9b2742cda..07ce6c308a 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -1,11 +1,12 @@ ! 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 accessors concurrency.flags io.files ; +io.backend accessors concurrency.flags io.files assocs +io.files.private windows destructors ; IN: io.windows.launcher TUPLE: CreateProcess-args diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 7755f111c6..3e0f4e9e86 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -32,7 +32,8 @@ M: windows normalize-directory ( string -- string ) : default-security-attributes ( -- obj ) "SECURITY_ATTRIBUTES" - "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 @@ -47,8 +48,8 @@ M: win32-file close-handle ( handle -- ) ! Clean up resources (open handle) if add-completion fails : open-file ( path access-mode create-mode flags -- handle ) [ - >r >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 ; @@ -95,7 +96,8 @@ M: win32-file close-handle ( handle -- ) >r (open-append) r> 2dup set-file-pointer ; TUPLE: FileArgs - hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ; + hFile lpBuffer nNumberOfBytesToRead + lpNumberOfBytesRet lpOverlapped ; C: FileArgs @@ -195,4 +197,3 @@ M: windows addrinfo-error ( n -- ) : tcp-socket ( addrspec -- socket ) protocol-family SOCK_STREAM open-socket ; - From a870b7d635984ed4004940004724f823f98eb0fa Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 4 Apr 2008 12:26:39 -0500 Subject: [PATCH 479/886] builder: remove reference to 'cwd' --- extra/builder/builder.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 75664ce5e5..2982f675b4 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -127,10 +127,10 @@ SYMBOL: build-status "report" utf8 [ - "Build machine: " write host-name print - "CPU: " write cpu print - "OS: " write os print - "Build directory: " write cwd print + "Build machine: " write host-name print + "CPU: " write cpu print + "OS: " write os print + "Build directory: " write current-directory get print git-clone [ "git clone failed" print ] run-or-bail From 89d4c4ca595d96f831cac149cd58feeb0690ff99 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 4 Apr 2008 12:27:30 -0500 Subject: [PATCH 480/886] newfx: add a couple of variants --- extra/newfx/newfx.factor | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index 53cda66dfc..ae92f8f6c0 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -22,11 +22,16 @@ IN: newfx ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: nth-is-of ( i val seq -- seq ) dup >r swapd set-nth r> ; +: is-nth-of ( val i seq -- seq ) dup >r set-nth r> ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : mutate-nth ( seq i val -- ) swap rot set-nth ; -: mutate-at-nth ( seq val i -- ) rot set-nth ; +: mutate-nth-at ( seq val i -- ) rot set-nth ; : mutate-nth-of ( i val seq -- ) swapd set-nth ; -: mutate-at-nth-of ( val i seq -- ) set-nth ; +: mutate-nth-at-of ( val i seq -- ) set-nth ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From a245dcb0c9bbd5a88a9eda47470acc58c608d618 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 4 Apr 2008 12:40:25 -0500 Subject: [PATCH 481/886] builder: up bootstrap timeout to 60 minutes (yikes!) --- extra/builder/builder.factor | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index c555233410..d335403b2c 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -13,8 +13,6 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : cd ( path -- ) current-directory set ; - : cd ( path -- ) set-current-directory ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -56,18 +54,10 @@ IN: builder [ "make" ] if ; -! : do-make-clean ( -- ) { "make" "clean" } try-process ; - : do-make-clean ( -- ) { gnu-make "clean" } to-strings try-process ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : make-vm ( -- desc ) -! -! { "make" } >>command -! "../compile-log" >>stdout -! +stdout+ >>stderr ; - : make-vm ( -- desc ) { gnu-make } to-strings >>command @@ -94,7 +84,7 @@ IN: builder +closed+ >>stdin "../boot-log" >>stdout +stdout+ >>stderr - 20 minutes >>timeout ; + 60 minutes >>timeout ; : do-bootstrap ( -- ) bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ; From 5f50c1cbffbac2e3d3b91d810a252b193a772bf8 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 4 Apr 2008 15:22:21 -0500 Subject: [PATCH 482/886] builder: update to handle latest changes --- extra/builder/builder.factor | 8 ++---- extra/builder/release/release.factor | 26 +++++++++--------- extra/builder/test/test.factor | 41 ++++++++++++---------------- 3 files changed, 34 insertions(+), 41 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index d335403b2c..141a78304a 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -49,7 +49,7 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : gnu-make ( -- string ) - os { "freebsd" "openbsd" "netbsd" } member? + os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ; @@ -118,8 +118,8 @@ SYMBOL: build-status "report" utf8 [ "Build machine: " write host-name print - "CPU: " write cpu print - "OS: " write os print + "CPU: " write cpu . + "OS: " write os . "Build directory: " write current-directory get print git-clone [ "git clone failed" print ] run-or-bail @@ -148,8 +148,6 @@ SYMBOL: build-status "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. diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index d76eda8013..9b449a51c5 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -1,6 +1,6 @@ USING: kernel system namespaces sequences splitting combinators - io io.files io.launcher + io io.files io.launcher prettyprint bake combinators.cleave builder.common builder.util ; IN: builder.release @@ -33,22 +33,22 @@ IN: builder.release ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: cpu- ( -- cpu ) cpu "." split "-" join ; +: cpu- ( -- cpu ) cpu unparse "." split "-" join ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: base-name ( -- string ) { "factor" os cpu- stamp> } to-strings "-" join ; +: base-name ( -- string ) + { "factor" [ os unparse ] cpu- stamp> } to-strings "-" join ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : extension ( -- extension ) - os { - { "linux" [ ".tar.gz" ] } - { "winnt" [ ".zip" ] } - { "macosx" [ ".dmg" ] } + { [ os winnt? ] [ ".zip" ] } + { [ os macosx? ] [ ".dmg" ] } + { [ os unix? ] [ ".tar.gz" ] } } - case ; + cond ; : archive-name ( -- string ) base-name extension append ; @@ -69,9 +69,9 @@ IN: builder.release : archive-cmd ( -- cmd ) { - { [ windows? ] [ windows-archive-cmd ] } - { [ macosx? ] [ macosx-archive-cmd ] } - { [ unix? ] [ unix-archive-cmd ] } + { [ os windows? ] [ windows-archive-cmd ] } + { [ os macosx? ] [ macosx-archive-cmd ] } + { [ os unix? ] [ unix-archive-cmd ] } } cond ; @@ -83,13 +83,13 @@ IN: builder.release { "rm" "-rf" common-files } to-strings try-process ; : remove-factor-app ( -- ) - macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ; + os macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: upload-to-factorcode -: platform ( -- string ) { os cpu- } to-strings "-" join ; +: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ; : remote-location ( -- dest ) "factorcode.org:/var/www/factorcode.org/newsite/downloads" diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index 3634082f56..d5c3e9cd94 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -1,40 +1,35 @@ -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 sequences assocs continuations +! vocabs vocabs.loader +! io +! io.files +! prettyprint +! tools.vocabs +! tools.test +! io.encodings.utf8 +! combinators.cleave +! help.lint +! bootstrap.stage2 benchmark builder.util ; + +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 ; From fa15df31890ee5edc0574f87590e791829e59896 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 4 Apr 2008 16:21:45 -0500 Subject: [PATCH 483/886] fix unit test --- extra/io/windows/nt/files/files-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/windows/nt/files/files-tests.factor b/extra/io/windows/nt/files/files-tests.factor index 1e6268fbc0..a08241ad1b 100755 --- a/extra/io/windows/nt/files/files-tests.factor +++ b/extra/io/windows/nt/files/files-tests.factor @@ -1,5 +1,5 @@ USING: io.files kernel tools.test io.backend -io.windows.nt.files splitting sequences ; +io.windows.nt.files splitting sequences io.files.private ; IN: io.windows.nt.files.tests [ f ] [ "\\foo" absolute-path? ] unit-test From 979d0b7dfedd7930addfd8c3c3db61fd4bd39132 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 19:30:04 -0500 Subject: [PATCH 484/886] Fixing unit tests --- core/compiler/tests/templates-early.factor | 4 ++-- extra/io/windows/nt/files/files-tests.factor | 4 +--- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor index 71da9436f1..004d088343 100755 --- a/core/compiler/tests/templates-early.factor +++ b/core/compiler/tests/templates-early.factor @@ -2,7 +2,7 @@ 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 ; : ( n -- vreg ) int-regs ; @@ -178,7 +178,7 @@ SYMBOL: template-chosen ] unit-test [ t ] [ - phantom-datastack get [ cached? ] all? + phantom-datastack get stack>> [ cached? ] all? ] unit-test ! >r diff --git a/extra/io/windows/nt/files/files-tests.factor b/extra/io/windows/nt/files/files-tests.factor index a08241ad1b..0fa4b4151c 100755 --- a/extra/io/windows/nt/files/files-tests.factor +++ b/extra/io/windows/nt/files/files-tests.factor @@ -1,5 +1,5 @@ USING: io.files kernel tools.test io.backend -io.windows.nt.files splitting sequences io.files.private ; +io.windows.nt.files splitting sequences ; IN: io.windows.nt.files.tests [ f ] [ "\\foo" absolute-path? ] unit-test @@ -27,8 +27,6 @@ IN: io.windows.nt.files.tests [ f ] [ "." root-directory? ] unit-test [ f ] [ ".." root-directory? ] unit-test -[ ] [ "" resource-path cd ] unit-test - [ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test [ "\\\\?\\C:\\builds\\factor\\log.txt" ] [ From d046c3b614bc78cbd4cb468c018f0ae6d6f50e8d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 19:40:08 -0500 Subject: [PATCH 485/886] Documentation updates --- core/classes/builtin/builtin-docs.factor | 4 ++-- core/classes/tuple/tuple-docs.factor | 2 +- core/classes/tuple/tuple.factor | 4 ++-- core/parser/parser-docs.factor | 6 +++--- core/prettyprint/sections/sections-docs.factor | 5 +++-- 5 files changed, 11 insertions(+), 10 deletions(-) diff --git a/core/classes/builtin/builtin-docs.factor b/core/classes/builtin/builtin-docs.factor index 6c5c262087..054587ff14 100644 --- a/core/classes/builtin/builtin-docs.factor +++ b/core/classes/builtin/builtin-docs.factor @@ -13,9 +13,9 @@ 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" } + { $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 prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" } + { $example "USING: classes.builtin prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" } } ; HELP: builtins diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 4ee72cdf83..5d35afb7d3 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -296,7 +296,7 @@ HELP: tuple-slots { tuple-slots tuple>array } related-words HELP: define-tuple-slots -{ $values { "class" tuple-class } { "slots" "a sequence of strings" } } +{ $values { "class" tuple-class } } { $description "Defines slot accessor and mutator words for the tuple." } $low-level-note ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 546f7b15e8..8b5972417d 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -40,7 +40,7 @@ PRIVATE> >r copy-tuple-slots r> layout-class prefix ; -: tuple-slots ( tuple -- array ) +: tuple-slots ( tuple -- seq ) prepare-tuple>array drop copy-tuple-slots ; : slots>tuple ( tuple class -- array ) @@ -48,7 +48,7 @@ PRIVATE> [ tuple-size ] [ [ set-array-nth ] curry ] bi 2each ] keep ; -: >tuple ( tuple -- array ) +: >tuple ( tuple -- seq ) unclip slots>tuple ; : slot-names ( class -- seq ) diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 61fd9f7f30..5adecca206 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -1,7 +1,7 @@ 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" @@ -446,8 +446,8 @@ HELP: eval { $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ; 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 } "." } ; +{ $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." } ; diff --git a/core/prettyprint/sections/sections-docs.factor b/core/prettyprint/sections/sections-docs.factor index b07e83d0d1..bb1752b72e 100755 --- a/core/prettyprint/sections/sections-docs.factor +++ b/core/prettyprint/sections/sections-docs.factor @@ -1,6 +1,7 @@ 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." } ; @@ -78,7 +79,7 @@ HELP: section } } ; HELP: construct-section -{ $values { "style" hashtable } { "length" integer } { "section" 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: Date: Fri, 4 Apr 2008 21:14:24 -0500 Subject: [PATCH 486/886] builder: fix minor bug --- extra/builder/builder.factor | 59 +++++++++++++++++++++++++----------- 1 file changed, 41 insertions(+), 18 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 141a78304a..8e9565f82a 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -2,7 +2,7 @@ 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 + debugger io.encodings.utf8 calendar tools.test builder.common @@ -17,10 +17,18 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: builds/factor ( -- path ) builds "factor" append-path ; +: build-dir ( -- path ) builds stamp> append-path ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : prepare-build-machine ( -- ) builds make-directory - builds cd - { "git" "clone" "git://factorcode.org/git/factor.git" } run-process drop ; + builds + [ + { "git" "clone" "git://factorcode.org/git/factor.git" } try-process + ] + with-directory ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -70,8 +78,8 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : copy-image ( -- ) - builds "factor" append-path my-boot-image-name append-path ".." copy-file-into - builds "factor" append-path my-boot-image-name append-path "." copy-file-into ; + builds/factor my-boot-image-name append-path ".." copy-file-into + builds/factor my-boot-image-name append-path "." copy-file-into ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -184,15 +192,27 @@ SYMBOL: builder-recipients ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: compress-image ( -- ) - { "bzip2" my-boot-image-name } to-strings run-process drop ; +: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ; + +! : build ( -- ) +! [ (build) ] try +! builds cd stamp> cd +! [ send-builder-email ] try +! { "rm" "-rf" "factor" } [ ] run-or-bail +! [ compress-image ] try ; : build ( -- ) - [ (build) ] failsafe - builds cd stamp> cd - [ send-builder-email ] [ drop "not sending mail" . ] recover - { "rm" "-rf" "factor" } run-process drop - [ compress-image ] failsafe ; + [ + (build) + build-dir + [ + { "rm" "-rf" "factor" } try-process + compress-image + ] + with-directory + ] + try + send-builder-email ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -209,7 +229,7 @@ USE: bootstrap.image.download : updates-available? ( -- ? ) git-id - git-pull run-process drop + git-pull try-process git-id = not ; @@ -222,12 +242,15 @@ USE: bootstrap.image.download : build-loop ( -- ) builds-check [ - builds "/factor" append cd - updates-available? new-image-available? or - [ build ] - when + builds/factor + [ + updates-available? new-image-available? or + [ build ] + when + ] + with-directory ] - failsafe + try 5 minutes sleep build-loop ; From 3bd09a2d9a4975bd3f2a69297b9aa349ec6266e1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 21:37:05 -0500 Subject: [PATCH 487/886] Removing obsolete directory --- extra/cel-shading/authors.txt | 1 - extra/cel-shading/summary.txt | 1 - extra/cel-shading/tags.txt | 3 --- 3 files changed, 5 deletions(-) delete mode 100644 extra/cel-shading/authors.txt delete mode 100644 extra/cel-shading/summary.txt delete mode 100644 extra/cel-shading/tags.txt diff --git a/extra/cel-shading/authors.txt b/extra/cel-shading/authors.txt deleted file mode 100644 index 6a0dc7293a..0000000000 --- a/extra/cel-shading/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Joe Groff \ No newline at end of file diff --git a/extra/cel-shading/summary.txt b/extra/cel-shading/summary.txt deleted file mode 100644 index 60da092f6d..0000000000 --- a/extra/cel-shading/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Stanford Bunny rendered with a cel-shading GLSL program \ No newline at end of file diff --git a/extra/cel-shading/tags.txt b/extra/cel-shading/tags.txt deleted file mode 100644 index 0db7e8e629..0000000000 --- a/extra/cel-shading/tags.txt +++ /dev/null @@ -1,3 +0,0 @@ -demos -opengl -glsl \ No newline at end of file From 315b46774883a91ea5b0689c7ce6b7049c3c6f5c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 21:44:39 -0500 Subject: [PATCH 488/886] Add debug messages --- vm/data_gc.c | 73 ++++++++++++++++++++++++++++++++++++++-------------- vm/data_gc.h | 3 ++- vm/debug.c | 10 +++---- vm/debug.h | 1 + vm/master.h | 2 +- 5 files changed, 62 insertions(+), 27 deletions(-) diff --git a/vm/data_gc.c b/vm/data_gc.c index 24f7cfecb9..372409c990 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -1,5 +1,20 @@ #include "master.h" +#define GC_DEBUG 1 + +#define ALLOC_DATA_HEAP "alloc_data_heap: gens=%ld, young_size=%ld, aging_size=%ld\n" +#define GC_REQUESTED "garbage_collection: code_gc=%d, growing_data_heap=%d, requested_bytes=%ld\n" +#define BEGIN_GC "begin_gc: code_gc=%d, 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; @@ -16,6 +31,8 @@ void init_cards_offset(void) F_DATA_HEAP *alloc_data_heap(CELL gens, CELL young_size, CELL aging_size) { + GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size); + young_size = align_page(young_size); aging_size = align_page(aging_size); @@ -133,7 +150,8 @@ void init_data_heap(CELL gens, 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_; } @@ -618,16 +636,14 @@ void begin_gc(CELL requested_bytes) 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) @@ -637,9 +653,6 @@ 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()) @@ -651,9 +664,19 @@ void end_gc(void) 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 { @@ -661,7 +684,7 @@ void end_gc(void) collected are now empty */ reset_generations(NURSERY,collecting_gen); - minor_collections++; + nursery_collections++; } if(collecting_code) @@ -688,6 +711,8 @@ void garbage_collection(CELL gen, return; } + GC_PRINT(GC_REQUESTED,code_gc,growing_data_heap_,requested_bytes); + s64 start = current_millis(); performing_gc = true; @@ -702,11 +727,15 @@ void garbage_collection(CELL gen, resort to growing the data heap */ if(collecting_gen == TENURED) { - growing_data_heap = true; - - /* see the comment in unmark_marked() */ if(collecting_code) + { + growing_data_heap = true; + + /* see the comment in unmark_marked() */ unmark_marked(&code_heap); + } + else + collecting_code = true; } /* we try collecting AGING space twice before going on to collect TENURED */ @@ -723,6 +752,7 @@ void garbage_collection(CELL gen, } } + GC_PRINT(BEGIN_GC,collecting_code,growing_data_heap,collecting_gen); begin_gc(requested_bytes); /* initialize chase pointer */ @@ -754,9 +784,12 @@ void garbage_collection(CELL gen, 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; } diff --git a/vm/data_gc.h b/vm/data_gc.h index 8f93ce79a1..77d54854d7 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -138,7 +138,8 @@ void init_data_heap(CELL gens, /* statistics */ s64 gc_time; -CELL minor_collections; +CELL nursery_collections; +CELL aging_collections; CELL cards_scanned; /* only meaningful during a GC */ diff --git a/vm/debug.c b/vm/debug.c index 101313a5ee..145004f113 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -218,10 +218,10 @@ void dump_memory(CELL from, CELL to) 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) @@ -230,13 +230,13 @@ void dump_generations(void) for(i = 0; 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", diff --git a/vm/debug.h b/vm/debug.h index ff8075c457..2ca6f8944c 100755 --- a/vm/debug.h +++ b/vm/debug.h @@ -2,5 +2,6 @@ void print_obj(CELL obj); 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); diff --git a/vm/master.h b/vm/master.h index 178c8fc7ff..0f4daa705b 100644 --- a/vm/master.h +++ b/vm/master.h @@ -20,13 +20,13 @@ #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" From 4139f0e8046c3803761b59ed706900af5f6fe524 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 22:22:38 -0500 Subject: [PATCH 489/886] Fix set-current-directory --- core/io/files/files.factor | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index ed1b94e556..6719d1334c 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -205,12 +205,11 @@ SYMBOL: current-directory M: object normalize-path ( path -- path' ) (normalize-path) ; -: with-directory ( path quot -- ) - >r (normalize-path) r> - current-directory swap with-variable ; inline - : set-current-directory ( path -- ) - normalize-path current-directory set ; + (normalize-path) current-directory set ; + +: with-directory ( path quot -- ) + >r (normalize-path) current-directory r> with-variable ; inline ! Creating directories HOOK: make-directory io-backend ( path -- ) From 6a823c4a698c8b0a8bf91d5dfd8c0d7cf70796f6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 22:40:37 -0500 Subject: [PATCH 490/886] Windows launcher fix --- extra/io/windows/launcher/launcher.factor | 3 ++- extra/io/windows/nt/launcher/launcher.factor | 2 ++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 07ce6c308a..6185159ddc 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -116,9 +116,10 @@ M: windows current-process-handle ( -- handle ) M: windows run-process* ( process -- handle ) [ + current-directory get (normalize-path) cd + dup make-CreateProcess-args tuck fill-redirection - current-directory get (normalize-path) cd dup call-CreateProcess lpProcessInformation>> ] with-destructors ; diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index 4bbf7c8e32..3aa2a9994b 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -120,6 +120,8 @@ M: winnt fill-redirection ( process args -- ) M: winnt (process-stream) [ + current-directory get (normalize-path) cd + dup make-CreateProcess-args fill-stdout-pipe From 3eeffbb10456e8b58c681635d60f23690ecbf120 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 22:40:48 -0500 Subject: [PATCH 491/886] Disable logging for now --- vm/code_gc.c | 1 + vm/data_gc.c | 15 ++++++++++----- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/vm/code_gc.c b/vm/code_gc.c index 5b0d2ebabb..54979b8a01 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -181,6 +181,7 @@ void free_unmarked(F_HEAP *heap) } break; case B_FREE: + printf("RECLAIMED\n"); if(prev && prev->status == B_FREE) prev->size += scan->size; break; diff --git a/vm/data_gc.c b/vm/data_gc.c index 372409c990..9f6b06a528 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -1,6 +1,6 @@ #include "master.h" -#define GC_DEBUG 1 +//#define GC_DEBUG 1 #define ALLOC_DATA_HEAP "alloc_data_heap: gens=%ld, young_size=%ld, aging_size=%ld\n" #define GC_REQUESTED "garbage_collection: code_gc=%d, growing_data_heap=%d, requested_bytes=%ld\n" @@ -12,7 +12,7 @@ #ifdef GC_DEBUG #define GC_PRINT printf #else - INLINE void GC_PRINT(...) { } + INLINE void GC_PRINT() { } #endif CELL init_zone(F_ZONE *z, CELL size, CELL start) @@ -584,7 +584,10 @@ CELL collect_next(CELL scan) do_slots(scan,copy_handle); if(collecting_code) + { + printf("do_code_slots\n"); do_code_slots(scan); + } return scan + untagged_object_size(scan); } @@ -720,6 +723,8 @@ void garbage_collection(CELL gen, growing_data_heap = growing_data_heap_; collecting_gen = gen; + //if(collecting_gen == TENURED) collecting_code = true; + /* we come back here if a generation is full */ if(setjmp(gc_jmp)) { @@ -727,15 +732,15 @@ void garbage_collection(CELL gen, resort to growing the data heap */ if(collecting_gen == TENURED) { - if(collecting_code) + //if(collecting_code) { growing_data_heap = true; /* see the comment in unmark_marked() */ unmark_marked(&code_heap); } - else - collecting_code = true; + //else + // collecting_code = true; } /* we try collecting AGING space twice before going on to collect TENURED */ From 21831d2c1624ea58d819f51f2192d9a6a287accc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 22:49:19 -0500 Subject: [PATCH 492/886] Fix Unix launcher with current directory --- extra/io/unix/launcher/launcher.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 5f0a9b96cb..9abedf38ac 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -70,7 +70,7 @@ USE: unix [ setup-priority setup-redirection - current-directory get resource-path cd + current-directory get (normalize-path) cd dup pass-environment? [ dup get-environment set-os-envs ] when From 5a4b5b01f96a7283d48d784fb6b6bcb0cb89e69f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Apr 2008 22:59:23 -0500 Subject: [PATCH 493/886] Fix using --- extra/io/windows/nt/launcher/launcher.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index 3aa2a9994b..a01ba4698e 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -4,8 +4,8 @@ USING: alien alien.c-types arrays continuations destructors io 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' ) From fe797265ec2b033a3af85840b84df94b93210946 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 4 Apr 2008 23:14:40 -0500 Subject: [PATCH 494/886] Working on delegate --- extra/delegate/delegate-tests.factor | 30 ++++++++---- extra/delegate/delegate.factor | 68 +++++++++++++++++++++------- 2 files changed, 73 insertions(+), 25 deletions(-) diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor index 2a0e013c1a..8563c12b75 100644 --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -1,4 +1,5 @@ -USING: delegate kernel arrays tools.test words math ; +USING: delegate kernel arrays tools.test words math definitions +compiler.units parser generic prettyprint io.streams.string ; IN: delegate.tests DEFER: example @@ -6,7 +7,6 @@ DEFER: example [ ] [ \ example "prop" [ 1+ ] change-word-prop ] unit-test [ 2 ] [ \ example "prop" word-prop ] unit-test - TUPLE: hello this that ; C: hello @@ -17,17 +17,29 @@ GENERIC: foo ( x -- y ) GENERIC: bar ( a -- b ) PROTOCOL: baz foo bar ; +: 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 ; GENERIC: bing ( c -- d ) -CONSULT: hello goodbye goodbye-these ; -M: hello bing dup hello? swap hello-that 2array ; +CONSULT: hello goodbye goodbye-those ; +M: hello bing hello-test ; MIMIC: bing goodbye hello -[ 1 { t 0 } ] [ 1 0 [ foo ] keep bar ] unit-test -[ { t 0 } ] [ 1 0 bing ] unit-test +[ 1 { t 1 0 } ] [ 1 0 [ foo ] [ bar ] bi ] unit-test +[ { t 1 0 } ] [ 1 0 bing ] unit-test [ 1 ] [ 1 0 f foo ] unit-test -[ { t 0 } ] [ 1 0 f bar ] unit-test -[ { f 0 } ] [ 1 0 f bing ] unit-test +[ { t 1 0 } ] [ 1 0 f bar ] unit-test +[ { f 1 0 } ] [ f 1 0 bing ] 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 ;\n" ] +[ [ baz see ] with-string-writer ] unit-test + +! [ ] [ [ baz forget ] with-compilation-unit ] unit-test +! [ f ] [ goodbye baz method ] unit-test diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index fc62c290df..a32a44db0f 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -1,17 +1,50 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: parser generic kernel classes words slots assocs sequences arrays -vectors ; +vectors definitions prettyprint ; 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> + seq-diff forget-all-methods ; + +: define-protocol ( protocol wordlist -- ) + 2dup forget-old-definitions + { } like "protocol-words" set-word-prop ; : 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 define-protocol ; parsing -PREDICATE: protocol < word "protocol-words" word-prop ; +PREDICATE: protocol < word protocol-words ; ! Subclass of symbol? + +M: protocol forget* + [ users-and-words forget-all-methods ] [ call-next-method ] bi ; + +M: protocol definition protocol-words ; + +M: protocol definer drop \ PROTOCOL: \ ; ; + +M: protocol synopsis* word-synopsis ; ! Necessary? GENERIC: group-words ( group -- words ) @@ -22,22 +55,23 @@ 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 ; + "slots" word-prop + [ [ slot-spec-reader ] map ] + [ [ slot-spec-writer ] map ] bi append ; + +! Consultation : define-consult-method ( word class quot -- ) pick suffix >r swap create-method r> define ; -: 3bi ( x y z p q -- p(x,y,z) q(x,y,z) ) - >r 3keep r> call ; inline - : change-word-prop ( word prop quot -- ) >r swap word-props r> change-at ; inline +: add ( item vector/f -- vector ) + 2dup member? [ nip ] [ ?push ] if ; + : declare-consult ( class group -- ) - "protocol-users" [ ?push ] change-word-prop ; + "protocol-users" [ add ] change-word-prop ; : define-consult ( class group quot -- ) >r 2dup declare-consult group-words swap r> @@ -46,10 +80,12 @@ M: tuple-class group-words : CONSULT: scan-word scan-word parse-definition swapd define-consult ; parsing +! Mimic still needs to be updated + : define-mimic ( group mimicker mimicked -- ) - >r >r group-words r> r> [ + rot group-words -rot [ pick "methods" word-prop at dup - [ >r swap create-method r> word-def define ] + [ >r swap create-method-in r> word-def define ] [ 3drop ] if ] 2curry each ; From 8b16816bf8ae66e0a3ffa0d22fd0376ee2aee974 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 17:15:43 +1300 Subject: [PATCH 495/886] Refactor satisfy peg parser --- extra/peg/peg.factor | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 3828fe7d9e..8b4991eef3 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences strings namespaces math assocs shuffle +USING: kernel sequences strings fry namespaces math assocs shuffle vectors arrays combinators.lib math.parser match unicode.categories sequences.lib compiler.units parser words quotations effects memoize accessors locals effects ; @@ -282,21 +282,20 @@ TUPLE: satisfy-parser quot ; MATCH-VARS: ?quot ; -: satisfy-pattern ( -- quot ) - [ - input-slice dup empty? [ - drop f - ] [ - unclip-slice dup ?quot call [ - - ] [ - 2drop f - ] if - ] if - ] ; +: parse-satisfy ( input quot -- result ) + swap dup empty? [ + 2drop f + ] [ + unclip-slice rot dupd call [ + + ] [ + 2drop f + ] if + ] if ; inline + M: satisfy-parser (compile) ( parser -- quot ) - quot>> \ ?quot satisfy-pattern match-replace ; + quot>> '[ input-slice , parse-satisfy ] ; TUPLE: range-parser min max ; From 80d11405a980c2d21d1a5b7b34ddab1368fdbc44 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 17:25:04 +1300 Subject: [PATCH 496/886] Refactor token peg parser --- extra/peg/peg.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 8b4991eef3..5ee497707d 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -3,7 +3,7 @@ USING: kernel sequences strings fry namespaces math assocs shuffle vectors arrays combinators.lib math.parser match unicode.categories sequences.lib compiler.units parser - words quotations effects memoize accessors locals effects ; + words quotations effects memoize accessors locals effects splitting ; IN: peg USE: prettyprint @@ -269,19 +269,17 @@ MATCH-VARS: ?token ; : parse-token ( input string -- result ) #! Parse the string, returning a parse result - 2dup head? [ - dup >r length tail-slice r> + dup >r ?head-slice [ + r> ] [ - 2drop f + r> 2drop f ] if ; M: token-parser (compile) ( parser -- quot ) - [ \ input-slice , symbol>> , \ parse-token , ] [ ] make ; + symbol>> '[ input-slice , parse-token ] ; TUPLE: satisfy-parser quot ; -MATCH-VARS: ?quot ; - : parse-satisfy ( input quot -- result ) swap dup empty? [ 2drop f @@ -320,6 +318,8 @@ M: range-parser (compile) ( parser -- quot ) TUPLE: seq-parser parsers ; +MATCH-VARS: ?quot ; + : seq-pattern ( -- quot ) [ dup [ From 7b73d2734fde7387c060816ceee79977404d0671 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 17:30:10 +1300 Subject: [PATCH 497/886] Refactor range peg parser --- extra/peg/peg.factor | 25 ++++++++++--------------- 1 file changed, 10 insertions(+), 15 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 5ee497707d..671b63949f 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -297,24 +297,19 @@ M: satisfy-parser (compile) ( parser -- quot ) TUPLE: range-parser min max ; -MATCH-VARS: ?min ?max ; - -: range-pattern ( -- quot ) - [ - input-slice dup empty? [ +: parse-range ( input min max -- result ) + pick empty? [ + 3drop f + ] [ + pick first -rot between? [ + unclip-slice + ] [ drop f - ] [ - 0 over nth dup - ?min ?max between? [ - [ 1 tail-slice ] dip - ] [ - 2drop f - ] if - ] if - ] ; + ] if + ] if ; M: range-parser (compile) ( parser -- quot ) - T{ range-parser _ ?min ?max } range-pattern match-replace ; + [ min>> ] [ max>> ] bi '[ input-slice , , parse-range ] ; TUPLE: seq-parser parsers ; From 102178f787aabd5f5e4ca6f9f3e2c61d3447eb91 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 17:51:42 +1300 Subject: [PATCH 498/886] Refactor seq peg parser --- extra/peg/peg.factor | 38 +++++++++++++++++++++----------------- 1 file changed, 21 insertions(+), 17 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 671b63949f..8c92605c44 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -313,34 +313,38 @@ M: range-parser (compile) ( parser -- quot ) TUPLE: seq-parser parsers ; -MATCH-VARS: ?quot ; +: ignore? ( ast -- bool ) + ignore = ; -: seq-pattern ( -- quot ) +: calc-seq-result ( prev-result current-result -- next-result ) [ - dup [ - ?quot [ - [ remaining>> swap (>>remaining) ] 2keep - ast>> dup ignore = [ - drop - ] [ - swap [ 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* ; + +: parse-seq-element ( result quot -- result ) + over [ + call calc-seq-result + ] [ + 2drop f + ] if ; inline M: seq-parser (compile) ( parser -- quot ) [ [ input-slice V{ } clone ] % - parsers>> [ compiled-parser \ ?quot seq-pattern match-replace % ] each + parsers>> [ compiled-parser 1quotation , \ parse-seq-element , ] each ] [ ] make ; TUPLE: choice-parser parsers ; +MATCH-VARS: ?quot ; + : choice-pattern ( -- quot ) [ [ ?quot ] unless* From 226d211342bef6b64354396fbcbb06e49700b5dc Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 17:54:18 +1300 Subject: [PATCH 499/886] Refactor choice peg parser --- extra/peg/peg.factor | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 8c92605c44..465e0dd757 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -343,21 +343,16 @@ M: seq-parser (compile) ( parser -- quot ) TUPLE: choice-parser parsers ; -MATCH-VARS: ?quot ; - -: choice-pattern ( -- quot ) - [ - [ ?quot ] unless* - ] ; - M: choice-parser (compile) ( parser -- quot ) [ f , - parsers>> [ compiled-parser \ ?quot choice-pattern match-replace % ] each + parsers>> [ compiled-parser 1quotation , \ unless* , ] each ] [ ] make ; TUPLE: repeat0-parser p1 ; +MATCH-VARS: ?quot ; + : (repeat0) ( quot result -- result ) over call [ [ remaining>> swap (>>remaining) ] 2keep From d4897fa007bd12dd2bd56dd7dd11cf4eeb7e885f Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 18:01:18 +1300 Subject: [PATCH 500/886] Refactor repeat0 and repeat1 peg parsers --- extra/peg/peg.factor | 42 +++++++++++++++--------------------------- 1 file changed, 15 insertions(+), 27 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 465e0dd757..8c427d5e27 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -351,48 +351,36 @@ M: choice-parser (compile) ( parser -- quot ) TUPLE: repeat0-parser p1 ; -MATCH-VARS: ?quot ; - -: (repeat0) ( quot result -- result ) +: (repeat) ( quot result -- result ) over call [ [ remaining>> swap (>>remaining) ] 2keep ast>> swap [ ast>> push ] keep - (repeat0) - ] [ + (repeat) + ] [ nip ] if* ; inline -: repeat0-pattern ( -- quot ) - [ - [ ?quot ] swap (repeat0) - ] ; - M: repeat0-parser (compile) ( parser -- quot ) - [ - [ input-slice V{ } clone ] % - p1>> compiled-parser \ ?quot repeat0-pattern match-replace % - ] [ ] make ; + p1>> compiled-parser 1quotation '[ + input-slice V{ } clone , swap (repeat) + ] ; TUPLE: repeat1-parser p1 ; -: repeat1-pattern ( -- quot ) +: repeat1-empty-check ( result -- result ) [ - [ ?quot ] swap (repeat0) [ - dup ast>> empty? [ - drop f - ] when - ] [ - f - ] if* - ] ; + dup ast>> empty? [ drop f ] when + ] [ + f + ] if* ; M: repeat1-parser (compile) ( parser -- quot ) - [ - [ input-slice V{ } clone ] % - p1>> compiled-parser \ ?quot repeat1-pattern match-replace % - ] [ ] make ; + p1>> compiled-parser 1quotation '[ + input-slice V{ } clone , swap (repeat) repeat1-empty-check + ] ; TUPLE: optional-parser p1 ; +MATCH-VARS: ?quot ; : optional-pattern ( -- quot ) [ From 3123654a8462634914010b5135261cc4237f9661 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 18:05:09 +1300 Subject: [PATCH 501/886] Refactor optional peg parser --- extra/peg/peg.factor | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 8c427d5e27..332f7164f8 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -380,17 +380,15 @@ M: repeat1-parser (compile) ( parser -- quot ) ] ; TUPLE: optional-parser p1 ; -MATCH-VARS: ?quot ; -: optional-pattern ( -- quot ) - [ - ?quot [ input-slice f ] unless* - ] ; +: check-optional ( result -- result ) + [ input-slice f ] unless* ; M: optional-parser (compile) ( parser -- quot ) - p1>> compiled-parser \ ?quot optional-pattern match-replace ; + p1>> compiled-parser 1quotation '[ @ check-optional ] ; TUPLE: semantic-parser p1 quot ; +MATCH-VARS: ?quot ; MATCH-VARS: ?parser ; From 796981e192e3a2f622be5c3bc455efd1e49bd6af Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 18:19:11 +1300 Subject: [PATCH 502/886] Refactor semantic peg parser --- extra/peg/peg.factor | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 332f7164f8..ab70745b11 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -392,18 +392,16 @@ MATCH-VARS: ?quot ; MATCH-VARS: ?parser ; -: semantic-pattern ( -- quot ) - [ - ?parser [ - dup parse-result-ast ?quot call [ drop f ] unless - ] [ - f - ] if* - ] ; +: check-semantic ( result quot -- result ) + over [ + over ast>> swap call [ drop f ] unless + ] [ + drop + ] if ; inline M: semantic-parser (compile) ( parser -- quot ) - [ p1>> compiled-parser ] [ quot>> ] bi - 2array { ?parser ?quot } semantic-pattern match-replace ; + [ p1>> compiled-parser 1quotation ] [ quot>> ] bi + '[ @ , check-semantic ] ; TUPLE: ensure-parser p1 ; From 247bf2137bbb785f644219f695388426bf05c389 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 18:30:11 +1300 Subject: [PATCH 503/886] Refactor ensure and ensure-not parsers --- extra/peg/peg.factor | 24 ++++++------------------ 1 file changed, 6 insertions(+), 18 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index ab70745b11..7970d761de 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -405,31 +405,19 @@ M: semantic-parser (compile) ( parser -- quot ) TUPLE: ensure-parser p1 ; -: ensure-pattern ( -- quot ) - [ - input-slice ?quot [ - ignore - ] [ - drop f - ] if - ] ; +: check-ensure ( old-input result -- result ) + [ ignore ] [ drop f ] if ; M: ensure-parser (compile) ( parser -- quot ) - p1>> compiled-parser \ ?quot ensure-pattern match-replace ; + p1>> compiled-parser 1quotation '[ input-slice @ check-ensure ] ; TUPLE: ensure-not-parser p1 ; -: ensure-not-pattern ( -- quot ) - [ - input-slice ?quot [ - drop f - ] [ - ignore - ] if - ] ; +: check-ensure-not ( old-input result -- result ) + [ drop f ] [ ignore ] if ; M: ensure-not-parser (compile) ( parser -- quot ) - p1>> compiled-parser \ ?quot ensure-not-pattern match-replace ; + p1>> compiled-parser 1quotation '[ input-slice @ check-ensure-not ] ; TUPLE: action-parser p1 quot ; From d93c7958fdad169d99dc1ddeb1ef01cae6594b0f Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 18:33:50 +1300 Subject: [PATCH 504/886] Refactor action peg parser --- extra/peg/peg.factor | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 7970d761de..fd41a67bfe 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -423,17 +423,16 @@ TUPLE: action-parser p1 quot ; MATCH-VARS: ?action ; -: action-pattern ( -- quot ) - [ - ?quot dup [ - dup ast>> ?action call - >>ast - ] when - ] ; +: check-action ( result quot -- result ) + over [ + over ast>> swap call >>ast + ] [ + drop + ] if ; inline M: action-parser (compile) ( parser -- quot ) - [ p1>> compiled-parser ] [ quot>> ] bi - 2array { ?quot ?action } action-pattern match-replace ; + [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ + @ , check-action ] ; : left-trim-slice ( string -- string ) #! Return a new string without any leading whitespace From 2744313ac14679397be74f345b63b9264b53db3b Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 18:36:17 +1300 Subject: [PATCH 505/886] Refactor sp peg parser --- extra/peg/peg.factor | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index fd41a67bfe..22405c9cbf 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -431,8 +431,7 @@ MATCH-VARS: ?action ; ] if ; inline M: action-parser (compile) ( parser -- quot ) - [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ - @ , check-action ] ; + [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ; : left-trim-slice ( string -- string ) #! Return a new string without any leading whitespace @@ -444,9 +443,9 @@ M: action-parser (compile) ( parser -- quot ) TUPLE: sp-parser p1 ; M: sp-parser (compile) ( parser -- quot ) - [ - \ input-slice , \ left-trim-slice , \ input-from , \ pos , \ set , p1>> compiled-parser , - ] [ ] make ; + p1>> compiled-parser 1quotation '[ + input-slice left-trim-slice input-from pos set @ + ] ; TUPLE: delay-parser quot ; From e00a392736161a3438476a7adc6a37fdc6482f6c Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 18:41:28 +1300 Subject: [PATCH 506/886] Refactor delay parser --- extra/peg/peg.factor | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 22405c9cbf..8d5d1c1560 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -453,11 +453,7 @@ 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>> % \ compile , - ] [ ] make - { } { "word" } memoize-quot - [ % \ execute , ] [ ] make ; + quot>> '[ @ compile ] { } { "word" } memoize-quot '[ @ execute ] ; TUPLE: box-parser quot ; From 9f16b80f3e3a8df70efaadf62f618522d440c6e4 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 5 Apr 2008 00:43:42 -0500 Subject: [PATCH 507/886] Fixing docs typo --- extra/io/encodings/utf16/utf16-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/encodings/utf16/utf16-docs.factor b/extra/io/encodings/utf16/utf16-docs.factor index bc0e943415..1666219db5 100644 --- a/extra/io/encodings/utf16/utf16-docs.factor +++ b/extra/io/encodings/utf16/utf16-docs.factor @@ -23,7 +23,7 @@ HELP: utf16 { $see-also "encodings-introduction" } ; 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 in of wide_t*." } +{ $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" } ; { utf16 utf16le utf16be utf16n } related-words From 6842a2829d1c8ff5e9937eae784481f3221f624a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 02:08:37 -0500 Subject: [PATCH 508/886] Fixing GC --- vm/code_gc.c | 3 +-- vm/data_gc.c | 47 +++++++++++++++++++---------------------------- vm/data_gc.h | 31 +++++++++++++++++++------------ 3 files changed, 39 insertions(+), 42 deletions(-) diff --git a/vm/code_gc.c b/vm/code_gc.c index 54979b8a01..8a05daf570 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -181,7 +181,6 @@ void free_unmarked(F_HEAP *heap) } break; case B_FREE: - printf("RECLAIMED\n"); if(prev && prev->status == B_FREE) prev->size += scan->size; break; @@ -290,7 +289,7 @@ DEFINE_PRIMITIVE(code_room) void code_gc(void) { - garbage_collection(TENURED,true,false,0); + garbage_collection(TENURED,false,0); } DEFINE_PRIMITIVE(code_gc) diff --git a/vm/data_gc.c b/vm/data_gc.c index 9f6b06a528..9b4f4fd583 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -1,10 +1,10 @@ #include "master.h" -//#define GC_DEBUG 1 +#define GC_DEBUG 0 #define ALLOC_DATA_HEAP "alloc_data_heap: gens=%ld, young_size=%ld, aging_size=%ld\n" -#define GC_REQUESTED "garbage_collection: code_gc=%d, growing_data_heap=%d, requested_bytes=%ld\n" -#define BEGIN_GC "begin_gc: code_gc=%d, growing_data_heap=%d, collecting_gen=%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" @@ -29,7 +29,10 @@ void init_cards_offset(void) - (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); @@ -405,7 +408,7 @@ void collect_stack_frame(F_STACK_FRAME *frame) 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; @@ -583,11 +586,8 @@ CELL collect_next(CELL scan) { do_slots(scan,copy_handle); - if(collecting_code) - { - printf("do_code_slots\n"); + if(collecting_gen == TENURED) do_code_slots(scan); - } return scan + untagged_object_size(scan); } @@ -641,11 +641,11 @@ void begin_gc(CELL requested_bytes) } #ifdef GC_DEBUG - //printf("\n"); + printf("\n"); dump_generations(); printf("Newspace: "); dump_zone(newspace); - //printf("\n"); + printf("\n"); #endif; } @@ -690,7 +690,7 @@ void end_gc(void) nursery_collections++; } - if(collecting_code) + if(collecting_gen == TENURED) { /* now that all reachable code blocks have been marked, deallocate the rest */ @@ -704,7 +704,6 @@ void end_gc(void) 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) { @@ -714,17 +713,14 @@ void garbage_collection(CELL gen, return; } - GC_PRINT(GC_REQUESTED,code_gc,growing_data_heap_,requested_bytes); + 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; - //if(collecting_gen == TENURED) collecting_code = true; - /* we come back here if a generation is full */ if(setjmp(gc_jmp)) { @@ -732,15 +728,10 @@ void garbage_collection(CELL gen, resort to growing the data heap */ if(collecting_gen == TENURED) { - //if(collecting_code) - { - growing_data_heap = true; + growing_data_heap = true; - /* see the comment in unmark_marked() */ - unmark_marked(&code_heap); - } - //else - // collecting_code = true; + /* see the comment in unmark_marked() */ + unmark_marked(&code_heap); } /* we try collecting AGING space twice before going on to collect TENURED */ @@ -757,7 +748,7 @@ void garbage_collection(CELL gen, } } - GC_PRINT(BEGIN_GC,collecting_code,growing_data_heap,collecting_gen); + GC_PRINT(BEGIN_GC,growing_data_heap,collecting_gen); begin_gc(requested_bytes); /* initialize chase pointer */ @@ -768,7 +759,7 @@ void garbage_collection(CELL gen, /* 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 */ @@ -800,7 +791,7 @@ void garbage_collection(CELL gen, void data_gc(void) { - garbage_collection(TENURED,false,false,0); + garbage_collection(TENURED,false,0); } DEFINE_PRIMITIVE(data_gc) diff --git a/vm/data_gc.h b/vm/data_gc.h index 77d54854d7..ee2e51b6f8 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -145,7 +145,6 @@ 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 */ @@ -222,7 +221,6 @@ CELL heap_scan_ptr; bool gc_off; void garbage_collection(volatile CELL gen, - bool code_gc, bool growing_data_heap_, CELL requested_bytes); @@ -308,18 +306,27 @@ allocation (which does not call GC because of possible roots in volatile registers) does not run out of memory */ #define ALLOT_BUFFER_ZONE 1024 +#define SUFFICIENT_ROOM(a) (nursery->here + ALLOT_BUFFER_ZONE + a <= nursery->end) + 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' */ + /* If there is enough room, return */ + if(SUFFICIENT_ROOM(a)) + return; + /* If the object is bigger than the nursery, grow immediately */ + else if(nursery->size - ALLOT_BUFFER_ZONE <= a) + garbage_collection(TENURED,true,a); + /* Otherwise, collect the nursery */ + else + { + garbage_collection(NURSERY,false,0); + + /* If there is still insufficient room, try growing the heap. + This can only happen if the number of generations is 1. */ + if(SUFFICIENT_ROOM(a)) return; + + garbage_collection(TENURED,true,a); + } } /* From cfa1c0201330481f072d579f1af31bed300013af Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 02:08:45 -0500 Subject: [PATCH 509/886] Add test case for GC --- core/memory/memory-tests.factor | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index 0c46e307df..0a021d1978 100755 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -1,8 +1,17 @@ USING: generic kernel kernel.private math memory prettyprint sequences tools.test words namespaces layouts classes -classes.builtin ; +classes.builtin arrays quotations ; IN: memory.tests +! Code GC wasn't kicking in when needed +: leak-step 800000 f 1quotation call drop ; + +: leak-loop 100 [ leak-step ] times ; + +[ ] [ leak-step leak-step leak-step data-gc ] unit-test + +[ ] [ leak-loop ] unit-test + TUPLE: testing x y z ; [ save-image-and-exit ] must-fail From 4515588b98c7cd07bee80f2979a9ca2f1dd561d6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 02:14:44 -0500 Subject: [PATCH 510/886] Fix compile error --- vm/data_gc.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/vm/data_gc.c b/vm/data_gc.c index 9b4f4fd583..010ceb49ad 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -31,8 +31,7 @@ void init_cards_offset(void) F_DATA_HEAP *alloc_data_heap(CELL gens, CELL young_size, - CELL aging_size, - CELL tenured_size) + CELL aging_size) { GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size); From 48d31a2ca01989bb07ca75afafee4d4d3a2648cd Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 5 Apr 2008 02:44:54 -0500 Subject: [PATCH 511/886] More changes to delegate --- extra/delegate/delegate-tests.factor | 11 +++-- extra/delegate/delegate.factor | 49 ++++++++++++++--------- extra/delegate/protocols/protocols.factor | 6 +-- 3 files changed, 38 insertions(+), 28 deletions(-) diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor index 8563c12b75..497a6c5120 100644 --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -15,7 +15,8 @@ C: goodbye 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 ; @@ -23,22 +24,26 @@ PROTOCOL: baz foo bar ; CONSULT: baz goodbye goodbye-these ; M: hello foo hello-this ; M: hello bar hello-test ; +M: hello whoa >r hello-this r> + ; GENERIC: bing ( c -- d ) +PROTOCOL: bee bing ; CONSULT: hello goodbye goodbye-those ; M: hello bing hello-test ; -MIMIC: bing goodbye hello +MIMIC: bee goodbye hello [ 1 { t 1 0 } ] [ 1 0 [ foo ] [ bar ] bi ] unit-test [ { t 1 0 } ] [ 1 0 bing ] unit-test [ 1 ] [ 1 0 f foo ] unit-test [ { t 1 0 } ] [ 1 0 f bar ] unit-test [ { f 1 0 } ] [ f 1 0 bing ] unit-test +[ 3 ] [ 1 0 2 whoa ] unit-test +[ 3 ] [ 1 0 f 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 ;\n" ] +[ "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 diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index a32a44db0f..f8e238b7db 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: parser generic kernel classes words slots assocs sequences arrays -vectors definitions prettyprint ; +vectors definitions prettyprint combinators.lib math ; IN: delegate ! Protocols @@ -26,21 +26,27 @@ IN: delegate seq-diff forget-all-methods ; : define-protocol ( protocol wordlist -- ) - 2dup forget-old-definitions + ! 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 dup f "inline" set-word-prop - parse-definition define-protocol ; parsing + 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 ; -M: protocol definition protocol-words ; +: show-words ( wordlist' -- wordlist ) + [ dup second zero? [ first ] when ] map ; + +M: protocol definition protocol-words show-words ; M: protocol definer drop \ PROTOCOL: \ ; ; @@ -51,18 +57,17 @@ 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 - [ [ slot-spec-reader ] map ] - [ [ slot-spec-writer ] map ] bi append ; + "slot-names" word-prop [ + [ reader-word ] [ writer-word ] bi + 2array [ 0 2array ] map + ] map concat ; ! Consultation : define-consult-method ( word class quot -- ) - pick suffix >r swap create-method r> define ; + [ drop swap first create-method ] + [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ; : change-word-prop ( word prop quot -- ) >r swap word-props r> change-at ; inline @@ -70,24 +75,28 @@ M: tuple-class group-words : add ( item vector/f -- vector ) 2dup member? [ nip ] [ ?push ] if ; -: declare-consult ( class group -- ) +: use-protocol ( class group -- ) "protocol-users" [ add ] change-word-prop ; -: define-consult ( class group quot -- ) - >r 2dup declare-consult group-words swap r> +: 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 -- ) - rot group-words -rot [ - pick "methods" word-prop at dup - [ >r swap create-method-in 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 diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor index f9b4c8648d..b1435e0dbc 100755 --- a/extra/delegate/protocols/protocols.factor +++ b/extra/delegate/protocols/protocols.factor @@ -9,10 +9,8 @@ PROTOCOL: sequence-protocol 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 @@ -28,5 +26,3 @@ PROTOCOL: prettyprint-section-protocol section-fits? indent-section? unindent-first-line? newline-after? short-section? short-section long-section
delegate>block add-section ; - - From b2cb88f49709125aa556963f8be06868743b6bbc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 04:01:46 -0500 Subject: [PATCH 512/886] GC: allocate large objects directly into tenured space --- core/alien/alien-docs.factor | 2 +- core/alien/compiler/compiler-tests.factor | 14 ++-- core/bootstrap/primitives.factor | 3 +- core/compiler/tests/float.factor | 2 +- core/compiler/tests/simple.factor | 2 +- core/continuations/continuations-tests.factor | 4 +- core/inference/known-words/known-words.factor | 4 +- core/memory/memory-docs.factor | 5 +- core/memory/memory-tests.factor | 2 - vm/code_gc.c | 12 +-- vm/code_gc.h | 2 - vm/code_heap.c | 2 +- vm/data_gc.c | 73 ++++++++--------- vm/data_gc.h | 81 +++++++++++-------- vm/debug.c | 2 +- vm/factor.c | 10 ++- vm/image.c | 12 ++- vm/image.h | 2 +- vm/primitives.c | 3 +- vm/profiler.c | 7 +- 20 files changed, 119 insertions(+), 125 deletions(-) diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index fcafe3441c..136af91bb2 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -204,7 +204,7 @@ ARTICLE: "alien-callback-gc" "Callbacks and code GC" "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" diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index f9dc426de1..dd2d9587cb 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -87,7 +87,7 @@ FUNCTION: tiny ffi_test_17 int x ; [ -1 indirect-test-1 ] must-fail : indirect-test-2 - "int" { "int" "int" } "cdecl" alien-indirect data-gc ; + "int" { "int" "int" } "cdecl" alien-indirect gc ; { 3 1 } [ indirect-test-2 ] must-infer-as @@ -97,7 +97,7 @@ unit-test : indirect-test-3 "int" { "int" "int" "int" "int" } "stdcall" alien-indirect - data-gc ; + gc ; << "f-stdcall" f "stdcall" add-library >> @@ -106,13 +106,13 @@ unit-test : ffi_test_18 ( w x y z -- int ) "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } - alien-invoke data-gc ; + 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 data-gc ; + alien-invoke gc ; [ 11 6 -7 ] [ 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z @@ -143,7 +143,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3, "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 code-gc 3 ; + alien-invoke gc 3 ; [ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test @@ -312,14 +312,14 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; : callback-4 "void" { } "cdecl" [ "Hello world" write ] alien-callback - data-gc ; + gc ; [ "Hello world" ] [ [ callback-4 callback_test_1 ] with-string-writer ] unit-test : callback-5 - "void" { } "cdecl" [ data-gc ] alien-callback ; + "void" { } "cdecl" [ gc ] alien-callback ; [ "testing" ] [ "testing" callback-5 callback_test_1 diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 516ff7ed74..a5348db973 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -640,8 +640,7 @@ define-builtin { "setenv" "kernel.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" } diff --git a/core/compiler/tests/float.factor b/core/compiler/tests/float.factor index 0d457a8310..81ab750305 100755 --- a/core/compiler/tests/float.factor +++ b/core/compiler/tests/float.factor @@ -2,7 +2,7 @@ IN: compiler.tests 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 diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index 13b7de6987..09b0c190e6 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -48,7 +48,7 @@ IN: compiler.tests [ 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 diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index d5ede60086..8b396763e1 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -46,8 +46,8 @@ IN: continuations.tests ! Weird PowerPC bug. [ ] [ [ "4" throw ] ignore-errors - data-gc - data-gc + gc + gc ] unit-test [ f ] [ { } kernel-error? ] unit-test diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 5092b86a4d..99737e0ac5 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -358,9 +358,7 @@ M: object infer-call \ (directory) { string } { array } set-primitive-effect -\ data-gc { } { } set-primitive-effect - -\ code-gc { } { } set-primitive-effect +\ gc { } { } set-primitive-effect \ gc-time { } { integer } set-primitive-effect diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor index e29844dc89..75876a3c8f 100755 --- a/core/memory/memory-docs.factor +++ b/core/memory/memory-docs.factor @@ -37,12 +37,9 @@ HELP: instances { $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." } ; diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index 0a021d1978..2b5b1333c0 100755 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -8,8 +8,6 @@ IN: memory.tests : leak-loop 100 [ leak-step ] times ; -[ ] [ leak-step leak-step leak-step data-gc ] unit-test - [ ] [ leak-loop ] unit-test TUPLE: testing x y z ; diff --git a/vm/code_gc.c b/vm/code_gc.c index 8a05daf570..93eb49c1be 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -287,16 +287,6 @@ DEFINE_PRIMITIVE(code_room) dpush(tag_fixnum((code_heap.segment->size) / 1024)); } -void code_gc(void) -{ - garbage_collection(TENURED,false,0); -} - -DEFINE_PRIMITIVE(code_gc) -{ - code_gc(); -} - /* Dump all code blocks for debugging */ void dump_heap(F_HEAP *heap) { @@ -444,7 +434,7 @@ critical here */ void compact_code_heap(void) { /* Free all unreachable code blocks */ - code_gc(); + gc(); fprintf(stderr,"*** Code heap compaction...\n"); fflush(stderr); diff --git a/vm/code_gc.h b/vm/code_gc.h index 4341d8ce64..32f304c16c 100644 --- a/vm/code_gc.h +++ b/vm/code_gc.h @@ -85,8 +85,6 @@ void iterate_code_heap(CODE_HEAP_ITERATOR iter); 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); diff --git a/vm/code_heap.c b/vm/code_heap.c index e55188c6a8..ec63441bcb 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -224,7 +224,7 @@ CELL allot_code_block(CELL size) /* 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 */ diff --git a/vm/data_gc.c b/vm/data_gc.c index 010ceb49ad..c43fe69bd1 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -1,8 +1,6 @@ #include "master.h" -#define GC_DEBUG 0 - -#define ALLOC_DATA_HEAP "alloc_data_heap: gens=%ld, young_size=%ld, aging_size=%ld\n" +#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" @@ -31,25 +29,28 @@ void init_cards_offset(void) F_DATA_HEAP *alloc_data_heap(CELL gens, CELL young_size, - CELL aging_size) + CELL aging_size, + CELL tenured_size) { - GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_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); @@ -58,8 +59,8 @@ F_DATA_HEAP *alloc_data_heap(CELL gens, 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); @@ -67,31 +68,19 @@ F_DATA_HEAP *alloc_data_heap(CELL gens, CELL alloter = data_heap->segment->start; - alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter); + alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter); + alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter); - alloter = init_zone(&data_heap->generations[TENURED],aging_size,alloter); - alloter = init_zone(&data_heap->semispaces[TENURED],aging_size,alloter); - - int i; - - 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) @@ -104,10 +93,12 @@ 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); + new_aging_size, + new_tenured_size); } void dealloc_data_heap(F_DATA_HEAP *data_heap) @@ -141,9 +132,10 @@ void set_data_heap(F_DATA_HEAP *data_heap_) 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; @@ -258,7 +250,7 @@ void begin_scan(void) DEFINE_PRIMITIVE(begin_scan) { - data_gc(); + gc(); begin_scan(); } @@ -645,7 +637,7 @@ void begin_gc(CELL requested_bytes) printf("Newspace: "); dump_zone(newspace); printf("\n"); -#endif; +#endif } void end_gc(void) @@ -788,14 +780,14 @@ void garbage_collection(CELL gen, performing_gc = false; } -void data_gc(void) +void gc(void) { garbage_collection(TENURED,false,0); } -DEFINE_PRIMITIVE(data_gc) +DEFINE_PRIMITIVE(gc) { - data_gc(); + gc(); } /* Push total time spent on GC */ @@ -806,7 +798,8 @@ DEFINE_PRIMITIVE(gc_time) void simple_gc(void) { - maybe_gc(0); + if(nursery->here + ALLOT_BUFFER_ZONE > nursery->end) + garbage_collection(NURSERY,false,0); } DEFINE_PRIMITIVE(become) @@ -828,5 +821,5 @@ DEFINE_PRIMITIVE(become) forward_object(old_obj,new_obj); } - data_gc(); + gc(); } diff --git a/vm/data_gc.h b/vm/data_gc.h index ee2e51b6f8..acbc38a6cb 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -19,6 +19,8 @@ DECLARE_PRIMITIVE(begin_scan); DECLARE_PRIMITIVE(next_object); DECLARE_PRIMITIVE(end_scan); +void gc(void); + /* generational copying GC divides memory into zones */ typedef struct { /* allocation pointer is 'here'; its offset is hardcoded in the @@ -34,6 +36,7 @@ typedef struct { CELL young_size; CELL aging_size; + CELL tenured_size; CELL gen_count; @@ -134,6 +137,7 @@ CELL init_zone(F_ZONE *z, CELL size, CELL base); void init_data_heap(CELL gens, CELL young_size, CELL aging_size, + CELL tenured_size, bool secure_gc_); /* statistics */ @@ -186,10 +190,7 @@ INLINE void do_slots(CELL obj, void (* iter)(CELL *)) } } -/* 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)) @@ -306,37 +307,53 @@ allocation (which does not call GC because of possible roots in volatile registers) does not run out of memory */ #define ALLOT_BUFFER_ZONE 1024 -#define SUFFICIENT_ROOM(a) (nursery->here + ALLOT_BUFFER_ZONE + a <= nursery->end) - -INLINE void maybe_gc(CELL a) -{ - /* If there is enough room, return */ - if(SUFFICIENT_ROOM(a)) - return; - /* If the object is bigger than the nursery, grow immediately */ - else if(nursery->size - ALLOT_BUFFER_ZONE <= a) - garbage_collection(TENURED,true,a); - /* Otherwise, collect the nursery */ - else - { - garbage_collection(NURSERY,false,0); - - /* If there is still insufficient room, try growing the heap. - This can only happen if the number of generations is 1. */ - if(SUFFICIENT_ROOM(a)) return; - - garbage_collection(TENURED,true,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 the object is bigger than the nursery, allocate it in + tenured space */ + if(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); + + object = allot_zone(nursery,a); + } + 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; } @@ -345,8 +362,6 @@ 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); diff --git a/vm/debug.c b/vm/debug.c index 145004f113..840d252769 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -246,7 +246,7 @@ void dump_generations(void) void dump_objects(F_FIXNUM type) { - data_gc(); + gc(); begin_scan(); CELL obj; diff --git a/vm/factor.c b/vm/factor.c index 5825f97bdd..c8791b8972 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -13,15 +13,17 @@ void default_parameters(F_PARAMETERS *p) 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 = 2; + p->aging_size = 2; + p->tenured_size = 4 * CELLS; #endif p->secure_gc = false; @@ -84,6 +86,7 @@ void init_factor(F_PARAMETERS *p) /* 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 */ @@ -153,6 +156,7 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded 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; diff --git a/vm/image.c b/vm/image.c index 28c6c40c1d..653891fdfe 100755 --- a/vm/image.c +++ b/vm/image.c @@ -17,10 +17,14 @@ INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p) { 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]; @@ -145,7 +149,7 @@ void save_image(const F_CHAR *filename) DEFINE_PRIMITIVE(save_image) { /* do a full GC to push everything into tenured space */ - code_gc(); + gc(); save_image(unbox_native_string()); } diff --git a/vm/image.h b/vm/image.h index a57d1f5539..9b7df4e3a8 100755 --- a/vm/image.h +++ b/vm/image.h @@ -28,7 +28,7 @@ typedef struct { 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; diff --git a/vm/primitives.c b/vm/primitives.c index 6a6aeb9d46..038a7d84a5 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -90,8 +90,7 @@ void *primitives[] = { primitive_setenv, primitive_existsp, primitive_read_dir, - primitive_data_gc, - primitive_code_gc, + primitive_gc, primitive_gc_time, primitive_save_image, primitive_save_image_and_exit, diff --git a/vm/profiler.c b/vm/profiler.c index 72c9046eab..407fefaace 100755 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -57,10 +57,9 @@ void set_profiling(bool profiling) 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(); From b3a41fd79696d4ce878c4d42e9ced0df610bd7e4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 04:26:46 -0500 Subject: [PATCH 513/886] Merged code-gc, data-gc primitives into a gc primitive --- extra/cocoa/cocoa-tests.factor | 2 +- extra/tools/memory/memory-docs.factor | 3 +-- extra/tools/profiler/profiler-tests.factor | 2 +- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/extra/cocoa/cocoa-tests.factor b/extra/cocoa/cocoa-tests.factor index 20b7e2a02d..4b56d81626 100644 --- a/extra/cocoa/cocoa-tests.factor +++ b/extra/cocoa/cocoa-tests.factor @@ -10,7 +10,7 @@ CLASS: { "foo:" "void" { "id" "SEL" "NSRect" } - [ data-gc "x" set 2drop ] + [ gc "x" set 2drop ] } ; : test-foo diff --git a/extra/tools/memory/memory-docs.factor b/extra/tools/memory/memory-docs.factor index 11bb8d859b..28c219ee4d 100755 --- a/extra/tools/memory/memory-docs.factor +++ b/extra/tools/memory/memory-docs.factor @@ -15,8 +15,7 @@ ARTICLE: "tools.memory" "Object memory tools" "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" diff --git a/extra/tools/profiler/profiler-tests.factor b/extra/tools/profiler/profiler-tests.factor index e33201e22c..450a024a1e 100755 --- a/extra/tools/profiler/profiler-tests.factor +++ b/extra/tools/profiler/profiler-tests.factor @@ -8,7 +8,7 @@ alien tools.profiler.private sequences ; \ length profile-counter = ] unit-test -[ ] [ [ 10 [ data-gc ] times ] profile ] unit-test +[ ] [ [ 10 [ gc ] times ] profile ] unit-test [ ] [ [ 1000 sleep ] profile ] unit-test From 57268bcc7b644d8b0030f85c7adf6eb7f9197ccc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 04:26:58 -0500 Subject: [PATCH 514/886] Launcher wait cleanup, don't use kqueue anymore --- extra/io/launcher/launcher.factor | 21 ++++++++++++++++----- extra/io/unix/bsd/bsd.factor | 21 +++------------------ extra/io/unix/freebsd/freebsd.factor | 2 +- extra/io/unix/launcher/launcher.factor | 6 +----- extra/io/unix/linux/linux.factor | 2 -- extra/io/unix/macosx/macosx.factor | 2 +- extra/io/unix/openbsd/openbsd.factor | 2 +- extra/io/unix/unix.factor | 2 +- extra/io/windows/launcher/launcher.factor | 20 ++------------------ 9 files changed, 26 insertions(+), 52 deletions(-) diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 20c5bb92c9..fa4bdcaaea 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -3,7 +3,7 @@ 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 accessors ; +io.nonblocking accessors concurrency.flags ; IN: io.launcher TUPLE: process < identity-tuple @@ -56,14 +56,25 @@ SYMBOL: processes [ H{ } clone processes set-global ] "io.launcher" add-init-hook -HOOK: register-process io-backend ( process -- ) +HOOK: wait-for-processes io-backend ( -- ? ) -M: object register-process drop ; +SYMBOL: wait-flag + +: wait-loop ( -- ) + processes get assoc-empty? + [ wait-flag get-global lower-flag ] + [ wait-for-processes [ 100 sleep ] when ] if ; + +: start-wait-thread ( -- ) + 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 ; + V{ } clone swap processes get set-at + wait-flag get-global raise-flag ; M: process hashcode* process-handle hashcode* ; diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index 6f6517868e..12a64a41f9 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -1,23 +1,8 @@ ! 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 system ; - -! 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. +USING: io.backend io.unix.backend io.unix.select +namespaces system ; M: bsd init-io ( -- ) - mx set-global - kqueue-mx set-global - kqueue-mx get-global dup io-task-fd - 2dup mx get-global mx-reads set-at - mx get-global mx-writes set-at ; - -M: bsd register-process ( process -- ) - process-handle kqueue-mx get-global add-pid-task ; + mx set-global ; diff --git a/extra/io/unix/freebsd/freebsd.factor b/extra/io/unix/freebsd/freebsd.factor index 49fbc9af7e..65a208c556 100644 --- a/extra/io/unix/freebsd/freebsd.factor +++ b/extra/io/unix/freebsd/freebsd.factor @@ -1,3 +1,3 @@ -USING: io.unix.bsd io.backend system ; +USING: io.backend system ; freebsd set-io-backend diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 9abedf38ac..ef0107beb1 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -108,7 +108,7 @@ M: unix (process-stream) ! 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 tuck WNOHANG waitpid dup 0 <= [ 2drop t @@ -119,7 +119,3 @@ M: unix (process-stream) 2drop f ] if ] if ; - -: start-wait-thread ( -- ) - [ wait-for-processes [ 250 sleep ] when t ] - "Process reaper" spawn-server drop ; diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 78af0dd50d..30c61f6d21 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -123,5 +123,3 @@ M: linux init-io ( -- ) [ init-inotify ] bi ; linux set-io-backend - -[ start-wait-thread ] "io.unix.linux" add-init-hook diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor index c1c73ea018..277a38080c 100644 --- a/extra/io/unix/macosx/macosx.factor +++ b/extra/io/unix/macosx/macosx.factor @@ -1,4 +1,4 @@ -USING: io.unix.bsd io.backend io.monitors io.monitors.private +USING: io.backend io.monitors io.monitors.private continuations kernel core-foundation.fsevents sequences namespaces arrays system ; IN: io.unix.macosx diff --git a/extra/io/unix/openbsd/openbsd.factor b/extra/io/unix/openbsd/openbsd.factor index 9b3021646d..1907471263 100644 --- a/extra/io/unix/openbsd/openbsd.factor +++ b/extra/io/unix/openbsd/openbsd.factor @@ -1,3 +1,3 @@ -USING: io.unix.bsd io.backend core-foundation.fsevents system ; +USING: io.backend core-foundation.fsevents system ; openbsd set-io-backend diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index b4328f31b3..1e5638fb4a 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,5 +1,5 @@ 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 words ; +system vocabs.loader sequences words init ; "io.unix." os word-name append require diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 6185159ddc..410e13d266 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -144,26 +144,10 @@ M: windows kill-process* ( handle -- ) 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 ( -- ) - wait-flag set-global - [ wait-loop t ] "Process wait" spawn-server drop ; - -M: windows register-process - drop wait-flag get-global raise-flag ; - -[ start-wait-thread ] "io.windows.launcher" add-init-hook From 545b8a3d0525e79b84269287b2a5967bd2b55097 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 04:36:13 -0500 Subject: [PATCH 515/886] Default nursery size is 1mb; don't double nursery and accumulation when growing data heap --- vm/data_gc.c | 6 ++---- vm/factor.c | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/vm/data_gc.c b/vm/data_gc.c index c43fe69bd1..b7bba4997e 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -91,13 +91,11 @@ F_DATA_HEAP *alloc_data_heap(CELL gens, 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); } diff --git a/vm/factor.c b/vm/factor.c index c8791b8972..49f85c3485 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -21,7 +21,7 @@ void default_parameters(F_PARAMETERS *p) p->gen_count = 3; p->code_size = 8 * CELLS; - p->young_size = 2; + p->young_size = 1; p->aging_size = 2; p->tenured_size = 4 * CELLS; #endif From a30c60ea6309d3482560f707938e747e909705d9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 04:58:22 -0500 Subject: [PATCH 516/886] Fix UI breakage --- extra/ui/gadgets/gadgets.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index c4f11f2e87..3ad76b0a16 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -396,10 +396,10 @@ M: gadget request-focus-on gadget-parent request-focus-on ; 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 ) - [ gadget-parent ] follow ; + [ gadget-focus ] follow ; : make-gadget ( quot gadget -- gadget ) [ \ make-gadget rot with-variable ] keep ; inline From e545c90453d263e1a7df74794e9eb5c6048a50e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 04:58:34 -0500 Subject: [PATCH 517/886] Bigger nursery/aging spaces on 64 bit --- vm/factor.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/vm/factor.c b/vm/factor.c index 49f85c3485..c3d85eff5e 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -21,8 +21,8 @@ void default_parameters(F_PARAMETERS *p) p->gen_count = 3; p->code_size = 8 * CELLS; - p->young_size = 1; - p->aging_size = 2; + p->young_size = CELLS / 4; + p->aging_size = CELLS / 2; p->tenured_size = 4 * CELLS; #endif From 1d3205c69ef589ce75533490a4eca6f6b7a9c220 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 05:50:39 -0500 Subject: [PATCH 518/886] Fix BSD I/O --- extra/io/unix/freebsd/freebsd.factor | 2 +- extra/io/unix/macosx/macosx.factor | 2 +- extra/io/unix/netbsd/netbsd.factor | 2 +- extra/io/unix/openbsd/openbsd.factor | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/io/unix/freebsd/freebsd.factor b/extra/io/unix/freebsd/freebsd.factor index 65a208c556..49fbc9af7e 100644 --- a/extra/io/unix/freebsd/freebsd.factor +++ b/extra/io/unix/freebsd/freebsd.factor @@ -1,3 +1,3 @@ -USING: io.backend system ; +USING: io.unix.bsd io.backend system ; freebsd set-io-backend diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor index 277a38080c..c1c73ea018 100644 --- a/extra/io/unix/macosx/macosx.factor +++ b/extra/io/unix/macosx/macosx.factor @@ -1,4 +1,4 @@ -USING: io.backend io.monitors io.monitors.private +USING: io.unix.bsd io.backend io.monitors io.monitors.private continuations kernel core-foundation.fsevents sequences namespaces arrays system ; IN: io.unix.macosx diff --git a/extra/io/unix/netbsd/netbsd.factor b/extra/io/unix/netbsd/netbsd.factor index c5771c8ffc..ed134788b6 100644 --- a/extra/io/unix/netbsd/netbsd.factor +++ b/extra/io/unix/netbsd/netbsd.factor @@ -1,3 +1,3 @@ -USING: io.backend system ; +USING: io.unix.bsd io.backend system ; netbsd set-io-backend diff --git a/extra/io/unix/openbsd/openbsd.factor b/extra/io/unix/openbsd/openbsd.factor index 1907471263..dfc466f94b 100644 --- a/extra/io/unix/openbsd/openbsd.factor +++ b/extra/io/unix/openbsd/openbsd.factor @@ -1,3 +1,3 @@ -USING: io.backend core-foundation.fsevents system ; +USING: io.unix.bsd io.backend system ; openbsd set-io-backend From f7f43fa689c6999394317018e1866da75c52b723 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 07:00:09 -0500 Subject: [PATCH 519/886] ABOUT: updates vocabulary --- core/bootstrap/primitives.factor | 2 +- core/classes/tuple/tuple.factor | 2 +- core/compiler/units/units.factor | 10 +++++----- core/definitions/definitions.factor | 7 +++++++ core/words/words.factor | 9 +-------- extra/help/syntax/syntax.factor | 7 +++++-- 6 files changed, 20 insertions(+), 17 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index a5348db973..5836b4d3c5 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -30,7 +30,7 @@ crossref off ! 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 diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 8b5972417d..1aa283a675 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -174,7 +174,7 @@ M: tuple-class update-class 2drop [ [ update-tuples-after ] - [ changed-word ] + [ changed-definition ] [ redefined ] tri ] each-subclass diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index f87c1ec985..a780e0a745 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -56,12 +56,12 @@ GENERIC: definitions-changed ( assoc obj -- ) [ 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 -- ) @@ -73,7 +73,7 @@ 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-update-tuples-hook ( -- ) @@ -83,11 +83,11 @@ SYMBOL: update-tuples-hook call-recompile-hook call-update-tuples-hook dup [ drop crossref? ] assoc-contains? modify-code-heap - changed-definitions notify-definition-observers ; + updated-definitions notify-definition-observers ; : with-compilation-unit ( quot -- ) [ - H{ } clone changed-words set + H{ } clone changed-definitions set H{ } clone forgotten-definitions set H{ } clone outdated-tuples set new-definitions set diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 6ee21fc016..459512b83a 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -5,6 +5,13 @@ USING: kernel sequences namespaces assocs graphs ; ERROR: no-compilation-unit definition ; +SYMBOL: changed-definitions + +: changed-definition ( defspec -- ) + dup changed-definitions get + [ no-compilation-unit ] unless* + set-at ; + GENERIC: where ( defspec -- loc ) M: object where drop f ; diff --git a/core/words/words.factor b/core/words/words.factor index 2510c50347..7794a7f41f 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -144,19 +144,12 @@ PRIVATE> : redefined ( word -- ) H{ } clone visited [ (redefined) ] with-variable ; -SYMBOL: changed-words - -: changed-word ( word -- ) - dup changed-words get - [ no-compilation-unit ] unless* - set-at ; - : 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 -- ) diff --git a/extra/help/syntax/syntax.factor b/extra/help/syntax/syntax.factor index 9450f87215..65120a5d01 100755 --- a/extra/help/syntax/syntax.factor +++ b/extra/help/syntax/syntax.factor @@ -1,4 +1,4 @@ -! 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 ; @@ -16,4 +16,7 @@ IN: help.syntax over add-article >link r> remember-definition ; parsing : ABOUT: - scan-object in get vocab set-vocab-help ; parsing + scan-object + in get vocab + dup changed-definition + set-vocab-help ; parsing From d8ffc1124221c54bd2eeb34c574cad75f9abd766 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 07:00:59 -0500 Subject: [PATCH 520/886] Remove unnecessary dependency --- extra/locals/locals.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index fe4bd65c14..a961dec3bd 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -3,9 +3,8 @@ 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 accessors ; +definitions prettyprint hashtables prettyprint.sections +sequences.private effects generic compiler.units accessors ; IN: locals ! Inspired by From 1cc72a386e12f0c32ac0a22657afbe0cd1adb0b1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 07:35:36 -0500 Subject: [PATCH 521/886] Faster bootstrap --- core/bootstrap/compiler/compiler.factor | 4 +++- core/bootstrap/stage2.factor | 12 ++++-------- 2 files changed, 7 insertions(+), 9 deletions(-) diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 618c62f332..9e101126e6 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -19,7 +19,7 @@ IN: bootstrap.compiler 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 @@ -74,4 +74,6 @@ nl malloc calloc free memcpy } compile +vocabs [ words [ compiled? not ] subset compile "." write flush ] each + " done" print flush diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index c82ebbe9f8..a75b111e78 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -27,9 +27,9 @@ SYMBOL: bootstrap-time seq-diff [ "bootstrap." prepend require ] each ; -: compile-remaining ( -- ) - "Compiling remaining words..." print flush - vocabs [ words [ compiled? not ] subset compile ] each ; +! : compile-remaining ( -- ) +! "Compiling remaining words..." print flush +! vocabs [ words [ compiled? not ] subset compile ] each ; : count-words ( pred -- ) all-words swap subset length number>string write ; @@ -57,7 +57,7 @@ millis >r default-image-name "output-image" set-global -"math help handbook compiler random 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 @@ -79,10 +79,6 @@ os winnt? [ "windows.nt" require ] when load-components run-bootstrap-init - - "bootstrap.compiler" vocab [ - compile-remaining - ] when ] with-compiler-errors :errors From d5667fd4b19f9ec79ecff7838346dc4506968723 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 07:35:51 -0500 Subject: [PATCH 522/886] Better hashcodes --- core/classes/tuple/tuple.factor | 7 ++++--- core/kernel/kernel.factor | 2 ++ 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 1aa283a675..608fb8cf6c 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -225,9 +225,10 @@ M: tuple equal? M: tuple hashcode* [ - dup tuple-size -rot 0 -rot [ - swapd array-nth hashcode* bitxor - ] 2curry reduce + [ class hashcode ] [ tuple-size ] [ ] tri + >r rot r> [ + swapd array-nth hashcode* sequence-hashcode-step + ] 2curry each ] recursive-hashcode ; ! Deprecated diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 2b1dd3cf9c..b54d0a7879 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -118,6 +118,8 @@ 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 -- ? ) From c11ecef6237181c00ca64c78b414e55fc7a4c15a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 07:36:14 -0500 Subject: [PATCH 523/886] Vocab browser formatting fix --- extra/tools/vocabs/browser/browser.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor index 69ad9272a7..6ecb0bc5ad 100755 --- a/extra/tools/vocabs/browser/browser.factor +++ b/extra/tools/vocabs/browser/browser.factor @@ -79,7 +79,7 @@ C: vocab-author : describe-help ( vocab -- ) vocab-help [ - "Documentation" $heading nl ($link) + "Documentation" $heading ($link) ] when* ; : describe-children ( vocab -- ) From b2fa4e2f077a8aa1977f6dea0d66c84dd13345ae Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 07:57:26 -0500 Subject: [PATCH 524/886] unicode no longer depends on *.lib --- extra/unicode/breaks/breaks.factor | 6 +++--- extra/unicode/case/case.factor | 4 +++- extra/unicode/data/data.factor | 4 ++-- extra/unicode/normalize/normalize.factor | 5 ++--- 4 files changed, 10 insertions(+), 9 deletions(-) diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index 4c8c6491ca..7bb5776e78 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -1,6 +1,6 @@ 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 @@ -27,7 +27,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; [ "#" split1 drop ";" split1 drop trim-blank ] map [ empty? not ] subset [ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map - concat >set ; + concat [ dup ] H{ } map>assoc ; : other-extend-lines ( -- lines ) "extra/unicode/PropList.txt" resource-path ascii file-lines ; @@ -36,7 +36,7 @@ VALUE: other-extend CATEGORY: (extend) Me Mn ; : extend? ( ch -- ? ) - [ (extend)? ] [ other-extend key? ] either ; + dup (extend)? [ ] [ other-extend key? ] ?if ; : grapheme-class ( ch -- class ) { diff --git a/extra/unicode/case/case.factor b/extra/unicode/case/case.factor index 092a247204..06d22f0f63 100755 --- a/extra/unicode/case/case.factor +++ b/extra/unicode/case/case.factor @@ -1,8 +1,10 @@ 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 ; diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index d8e1e8937a..ba9c0370cc 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -1,5 +1,5 @@ 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 @@ -44,7 +44,7 @@ IN: unicode.data 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) diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor index d62beb1a2c..951430b2b5 100644 --- a/extra/unicode/normalize/normalize.factor +++ b/extra/unicode/normalize/normalize.factor @@ -1,5 +1,4 @@ -USING: sequences namespaces unicode.data kernel combinators.lib -math arrays ; +USING: sequences namespaces unicode.data kernel math arrays ; IN: unicode.normalize ! Conjoining Jamo behavior @@ -19,7 +18,7 @@ IN: unicode.normalize ! 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? ; From b886718609ad94b834051d7780505a81f15c4697 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 07:57:40 -0500 Subject: [PATCH 525/886] opengl no longer depends on *.lib --- extra/opengl/gl/extensions/extensions.factor | 6 +++--- extra/opengl/opengl-docs.factor | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor index b0a683dac6..b8ac396c2f 100644 --- a/extra/opengl/gl/extensions/extensions.factor +++ b/extra/opengl/gl/extensions/extensions.factor @@ -1,6 +1,6 @@ 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 ; ERROR: unknown-gl-platform ; << { @@ -30,7 +30,7 @@ reset-gl-function-number-counter : 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 diff --git a/extra/opengl/opengl-docs.factor b/extra/opengl/opengl-docs.factor index 5b1ee0d565..2788ebdfc2 100644 --- a/extra/opengl/opengl-docs.factor +++ b/extra/opengl/opengl-docs.factor @@ -1,5 +1,5 @@ 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 From f94596af576070c03acc34d0fbc95ef64c8da59a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 07:57:51 -0500 Subject: [PATCH 526/886] ui no longer depends on *.lib --- extra/ui/gestures/gestures.factor | 16 ++++++++-------- extra/ui/tools/interactor/interactor.factor | 5 +++-- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index 412a61bcb5..e52eff453a 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -2,9 +2,8 @@ ! 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 classes.tuple classes ui.gadgets combinators.lib -boxes -calendar alarms symbols ; +math.vectors classes.tuple classes ui.gadgets boxes +calendar alarms symbols combinators ; IN: ui.gestures : set-gestures ( class hash -- ) "gestures" set-word-prop ; @@ -188,11 +187,12 @@ SYMBOL: drag-timer : 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 ] [ t ] } + } cond nip ; : update-click# ( button -- ) global [ diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index c760867d71..8232094e76 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -3,7 +3,7 @@ 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 +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 @@ -105,7 +105,8 @@ M: interactor model-changed ] 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? [ From 2c76171c8a7b6fb4a502b7a8573bff4250f7d813 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 08:27:07 -0500 Subject: [PATCH 527/886] Fix profiler crash with large heap --- vm/data_gc.c | 21 +++++++++++++++++++++ vm/data_gc.h | 2 ++ vm/factor.c | 15 +-------------- vm/profiler.c | 16 +++++++++------- 4 files changed, 33 insertions(+), 21 deletions(-) diff --git a/vm/data_gc.c b/vm/data_gc.c index b7bba4997e..86552d6401 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -821,3 +821,24 @@ DEFINE_PRIMITIVE(become) 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; +} diff --git a/vm/data_gc.h b/vm/data_gc.h index acbc38a6cb..0adcf0ca39 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -365,3 +365,5 @@ DLLEXPORT void simple_gc(void); DECLARE_PRIMITIVE(gc); DECLARE_PRIMITIVE(gc_time); DECLARE_PRIMITIVE(become); + +CELL find_all_words(void); diff --git a/vm/factor.c b/vm/factor.c index c3d85eff5e..073b3e2e34 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -38,21 +38,8 @@ void do_stage1_init(void) fprintf(stderr,"*** Stage 2 early init... "); fflush(stderr); - GROWABLE_ARRAY(words); + CELL words = find_all_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); REGISTER_ROOT(words); CELL i; diff --git a/vm/profiler.c b/vm/profiler.c index 407fefaace..08bb846c85 100755 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -61,17 +61,19 @@ void set_profiling(bool profiling) 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); From 6f1d3d9174a95f3437366882bb86810c0d1e7b8a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 08:30:02 -0500 Subject: [PATCH 528/886] cocoa no longer depends on xml --- extra/cocoa/cocoa.factor | 2 ++ extra/cocoa/plists/plists.factor | 32 +++++++++++-------------- extra/tools/deploy/macosx/macosx.factor | 23 +++++++++--------- 3 files changed, 27 insertions(+), 30 deletions(-) diff --git a/extra/cocoa/cocoa.factor b/extra/cocoa/cocoa.factor index c94984f00b..f4cfb20591 100755 --- a/extra/cocoa/cocoa.factor +++ b/extra/cocoa/cocoa.factor @@ -42,11 +42,13 @@ SYMBOL: super-sent-messages "NSArray" "NSAutoreleasePool" "NSBundle" + "NSDictionary" "NSError" "NSEvent" "NSException" "NSMenu" "NSMenuItem" + "NSMutableDictionary" "NSNib" "NSNotification" "NSNotificationCenter" diff --git a/extra/cocoa/plists/plists.factor b/extra/cocoa/plists/plists.factor index 5965c74af8..9e05773f53 100644 --- a/extra/cocoa/plists/plists.factor +++ b/extra/cocoa/plists/plists.factor @@ -1,23 +1,19 @@ -! 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 [ ] 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 0 -> writeToFile:atomically: + [ "write-plist failed" throw ] unless ; diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 3a7f8e5d03..3121866d94 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -3,7 +3,8 @@ 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 ) @@ -20,23 +21,21 @@ IN: tools.deploy.macosx "fonts/" resource-path swap "Contents/Resources/" append-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." prepend "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" append-path - utf8 set-file-contents ; + write-plist ; : create-app-dir ( vocab bundle-name -- vm ) dup "Frameworks" copy-bundle-dir @@ -64,6 +63,6 @@ M: macosx deploy* ( vocab -- ) [ bundle-name create-app-dir ] keep [ bundle-name deploy.app-image ] keep namespace make-deploy-image - bundle-name show-in-finder + bundle-name normalize-path show-in-finder ] bind ] with-directory ; From 5f04c49d18ad3af6fa71e18789381485cd619d17 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 08:31:29 -0500 Subject: [PATCH 529/886] Fix windows deploy --- extra/tools/deploy/windows/windows.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor index 33ab877ee1..68b106663c 100755 --- a/extra/tools/deploy/windows/windows.factor +++ b/extra/tools/deploy/windows/windows.factor @@ -31,6 +31,6 @@ M: winnt deploy* [ deploy-name get create-exe-dir ] keep [ deploy-name get image-name ] keep [ namespace make-deploy-image ] keep - open-in-explorer + (normalize-path) open-in-explorer ] bind ] with-directory ; From b369ed600d1a9e4dd1e21ab765e8aef2d9f2682c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 5 Apr 2008 16:02:41 -0500 Subject: [PATCH 530/886] Graph docs fix --- core/graphs/graphs-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/graphs/graphs-docs.factor b/core/graphs/graphs-docs.factor index 1e4350d58c..f16f8cca3b 100644 --- a/core/graphs/graphs-docs.factor +++ b/core/graphs/graphs-docs.factor @@ -21,12 +21,12 @@ HELP: graph 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" } ; From 871831fdae1364b58d87fc5b56f703250accc646 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 20:07:30 -0500 Subject: [PATCH 531/886] Fixing hook stack effects --- core/generic/generic-tests.factor | 11 ---- core/generic/generic.factor | 5 +- core/generic/standard/engines/engines.factor | 2 + .../standard/engines/tuple/tuple.factor | 4 +- core/generic/standard/standard-tests.factor | 39 ++++++++++++- core/generic/standard/standard.factor | 55 ++++++++++--------- core/inference/backend/backend.factor | 4 +- 7 files changed, 79 insertions(+), 41 deletions(-) diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 524835f461..bbd7186a11 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -123,17 +123,6 @@ M: integer wii drop 6 ; [ 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 ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index f41f3ebcd0..cd08e80512 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -38,7 +38,10 @@ GENERIC: effective-method ( ... generic -- method ) : next-method ( class generic -- class/f ) [ next-method-class ] keep method ; -GENERIC: next-method-quot ( class generic -- quot ) +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 ; diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor index bf8d4fb67a..ccd64d1291 100644 --- a/core/generic/standard/engines/engines.factor +++ b/core/generic/standard/engines/engines.factor @@ -47,3 +47,5 @@ SYMBOL: (dispatch#) } case ; : picker ( -- quot ) \ (dispatch#) get (picker) ; + +GENERIC: extra-values ( method generic -- n ) diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 40e749f473..69d73aa872 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -66,7 +66,9 @@ PREDICATE: tuple-dispatch-engine-word < word "tuple-dispatch-engine" word-prop ; M: tuple-dispatch-engine-word stack-effect - "tuple-dispatch-generic" word-prop stack-effect ; + "tuple-dispatch-generic" word-prop + [ extra-values ] [ stack-effect clone ] bi + [ length + ] change-in ; M: tuple-dispatch-engine-word crossref? drop t ; diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index 2f58770b1a..a906acd324 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -1,7 +1,8 @@ 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 ; +words float-arrays byte-arrays bit-arrays parser namespaces +quotations inference vectors growable ; GENERIC: lo-tag-test @@ -194,7 +195,7 @@ M: ceo salary [ 102000 ] [ executive construct-boa salary ] unit-test [ ceo construct-boa salary ] -[ T{ inconsistent-next-method f 5 ceo salary } = ] must-fail-with +[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with [ intern construct-boa salary ] [ T{ no-next-method f intern salary } = ] must-fail-with @@ -233,3 +234,37 @@ M: c funky* "c" , call-next-method ; 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 ; + +[ 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 diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 9f9a892fd4..ed5134a624 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -67,7 +67,9 @@ ERROR: no-method object generic ; drop generic get "default-method" word-prop 1quotation ] unless ; -GENERIC: mangle-method ( method generic -- quot ) +: mangle-method ( method generic -- quot ) + [ 1quotation ] [ extra-values \ drop ] bi* + prepend [ ] like ; : single-combination ( word -- quot ) [ @@ -91,6 +93,23 @@ GENERIC: mangle-method ( method generic -- quot ) } cleave ] with-scope ; +ERROR: inconsistent-next-method class generic ; + +ERROR: no-next-method class generic ; + +: single-next-method-quot ( class generic -- quot ) + [ + [ drop [ instance? ] curry % ] + [ + 2dup next-method + [ 2nip 1quotation ] + [ [ no-next-method ] 2curry ] if* , + ] + [ [ inconsistent-next-method ] 2curry , ] + 2tri + \ if , + ] [ ] make ; + TUPLE: standard-combination # ; C: standard-combination @@ -107,8 +126,7 @@ PREDICATE: simple-generic < standard-generic : with-standard ( combination quot -- quot' ) >r #>> (dispatch#) r> with-variable ; inline -M: standard-generic mangle-method - drop 1quotation ; +M: standard-generic extra-values drop 0 ; M: standard-combination make-default-method [ empty-method ] with-standard ; @@ -118,30 +136,15 @@ M: standard-combination perform-combination 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 [ order [ instance? ] with find-last nip ] keep method ; -ERROR: inconsistent-next-method object class generic ; - -ERROR: no-next-method class generic ; - -M: standard-generic next-method-quot - [ - [ - [ [ instance? ] curry ] - [ dispatch# (picker) ] bi* prepend % - ] - [ - 2dup next-method - [ 2nip 1quotation ] - [ [ no-next-method ] 2curry ] if* , - ] - [ [ inconsistent-next-method ] 2curry , ] - 2tri - \ if , - ] [ ] make ; - TUPLE: hook-combination var ; C: hook-combination @@ -156,8 +159,7 @@ PREDICATE: hook-generic < generic M: hook-combination dispatch# drop 0 ; -M: hook-generic mangle-method - drop 1quotation [ drop ] prepend ; +M: hook-generic extra-values drop 1 ; M: hook-combination make-default-method [ error-method ] with-hook ; @@ -165,6 +167,9 @@ M: hook-combination make-default-method M: hook-combination perform-combination [ drop ] [ [ single-combination ] with-hook ] 2bi define ; +M: hook-combination next-method-quot* + [ single-next-method-quot ] with-hook ; + M: simple-generic definer drop \ GENERIC: f ; M: standard-generic definer drop \ GENERIC# f ; diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index c0de217bd1..3dcb1d2360 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -36,6 +36,8 @@ TUPLE: inference-error error type rstate ; M: inference-error compiler-error-type type>> ; +M: inference-error error-help error>> error-help ; + : (inference-error) ( ... class type -- * ) >r construct-boa r> recursive-state get @@ -359,7 +361,7 @@ TUPLE: effect-error word effect ; \ 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 -- ) From 1f838811e8a2a9e6d3a94337320109bc99439021 Mon Sep 17 00:00:00 2001 From: slava Date: Sat, 5 Apr 2008 19:15:35 -0500 Subject: [PATCH 532/886] Fix X11 UI --- extra/ui/x11/x11.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 9445486656..3ad10a6991 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -4,8 +4,9 @@ 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 +io.encodings.utf8 combinators debugger command-line qualified ui.render math.vectors classes.tuple opengl.gl threads ; +QUALIFIED: system IN: ui.x11 SINGLETON: x11-ui-backend @@ -261,5 +262,5 @@ M: x11-ui-backend ui ( -- ) x11-ui-backend ui-backend set-global -[ "DISPLAY" os-env "ui" "listener" ? ] +[ "DISPLAY" system:os-env "ui" "listener" ? ] main-vocab-hook set-global From ec620ef0c829f2955d9a685270bd5b55c91ccabc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 5 Apr 2008 20:22:33 -0500 Subject: [PATCH 533/886] inheritance with postgresql --- extra/db/db.factor | 52 ++++++++++++++--------- extra/db/postgresql/postgresql.factor | 59 +++++++++++++-------------- 2 files changed, 61 insertions(+), 50 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 55e672ec80..3cade1a895 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -11,14 +11,19 @@ TUPLE: db update-statements delete-statements ; -: ( handle -- obj ) - H{ } clone H{ } clone H{ } clone - db construct-boa ; +: construct-db ( class -- obj ) + construct-empty + 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 ) + construct-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 ; @@ -30,10 +35,12 @@ HOOK: db-close db ( handle -- ) handle>> db-close ] with-variable ; +! TUPLE: sql sql in-params out-params ; TUPLE: statement handle sql in-params out-params bind-params bound? ; -TUPLE: simple-statement ; -TUPLE: prepared-statement ; -TUPLE: nonthrowable-statement ; +TUPLE: simple-statement < statement ; +TUPLE: prepared-statement < statement ; +TUPLE: nonthrowable-statement < statement ; +TUPLE: throwable-statement < statement ; : make-nonthrowable ( obj -- obj' ) dup sequence? [ [ make-nonthrowable ] map @@ -41,14 +48,12 @@ TUPLE: nonthrowable-statement ; nonthrowable-statement construct-delegate ] 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 ; -: ( sql in out -- statement ) - { (>>sql) (>>in-params) (>>out-params) } statement construct ; +: construct-statement ( sql in out class -- statement ) + construct-empty + swap >>out-params + swap >>in-params + swap >>sql ; HOOK: db ( str in out -- statement ) HOOK: db ( str in out -- statement ) @@ -88,10 +93,17 @@ M: nonthrowable-statement execute-statement ( statement -- ) dup #rows >>max 0 >>n drop ; -: ( 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 ) + construct-empty + swap >>handle + >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r> + swap >>out-params + swap >>in-params + swap >>sql ; + + ! >r >r { sql>> in-params>> out-params>> } get-slots r> + ! { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set + ! construct r> construct-delegate ; : sql-row ( result-set -- seq ) dup #columns [ row-column ] with map ; @@ -110,7 +122,7 @@ M: nonthrowable-statement execute-statement ( statement -- ) 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 ; : default-query ( query -- result-set ) diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index f9805560ad..322143e7a2 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -5,40 +5,39 @@ kernel math math.parser namespaces prettyprint quotations 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 -namespaces.lib ; +namespaces.lib accessors ; 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 ; +TUPLE: postgresql-db < db + host port pgopts pgtty db user pass ; + +TUPLE: postgresql-statement < throwable-statement ; + +TUPLE: postgresql-result-set < result-set ; + : ( statement in out -- postgresql-statement ) - - postgresql-statement construct-delegate ; + postgresql-statement construct-statement ; 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 ; + >r first4 r> + swap >>db + swap >>pass + swap >>user + swap >>host ; -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 swap set-delegate ; +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 ; @@ -50,10 +49,10 @@ M: postgresql-statement bind-tuple ( tuple statement -- ) ] keep set-statement-bind-params ; 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 ; M: postgresql-result-set row-column ( result-set column -- obj ) >r dup result-set-handle swap result-set-n r> pq-get-string ; @@ -69,7 +68,7 @@ M: postgresql-statement query-results ( query -- result-set ) ] [ dup do-postgresql-statement ] if* - postgresql-result-set + postgresql-result-set construct-result-set dup init-result-set ; M: postgresql-result-set advance-row ( result-set -- ) @@ -90,7 +89,7 @@ M: postgresql-result-set dispose ( result-set -- ) M: postgresql-statement prepare-statement ( statement -- ) [ - >r db get db-handle "" r> + >r db get handle>> "" r> dup statement-sql swap statement-in-params length f PQprepare postgresql-error ] keep set-statement-handle ; From 29406f07ebb0ae91d5c488c12b4cc3df9efa0e4b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 21:30:16 -0500 Subject: [PATCH 534/886] Fix declaration --- core/generic/standard/engines/engines.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor index ccd64d1291..1f0b80e016 100644 --- a/core/generic/standard/engines/engines.factor +++ b/core/generic/standard/engines/engines.factor @@ -48,4 +48,4 @@ SYMBOL: (dispatch#) : picker ( -- quot ) \ (dispatch#) get (picker) ; -GENERIC: extra-values ( method generic -- n ) +GENERIC: extra-values ( generic -- n ) From f1bacc2110e1f8d64d5e59ecccc941e76b91d1d4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 22:59:31 -0500 Subject: [PATCH 535/886] Smarter breakpoint word --- extra/tools/annotations/annotations.factor | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor index 07038ceadf..ef710ea57d 100755 --- a/extra/tools/annotations/annotations.factor +++ b/extra/tools/annotations/annotations.factor @@ -2,10 +2,16 @@ ! 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 @@ -60,8 +66,16 @@ IN: tools.annotations : 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 ; From ab5ebd0f5a26f289539910c7cb9585ce885c22c6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 23:26:33 -0500 Subject: [PATCH 536/886] Fix buffering issue --- extra/io/unix/launcher/launcher.factor | 2 +- extra/unix/unix.factor | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index ef0107beb1..c104587c77 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -77,7 +77,7 @@ USE: unix get-arguments exec-args-with-path (io-error) - ] [ 255 exit ] recover ; + ] [ 255 _exit "Exit failed" throw ] recover ; M: unix current-process-handle ( -- handle ) getpid ; diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index e911a5c039..3d4ce3cd48 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -43,6 +43,7 @@ FUNCTION: int dup2 ( int oldd, int newd ) ; FUNCTION: int execv ( char* path, char** argv ) ; FUNCTION: int execvp ( char* path, char** argv ) ; FUNCTION: int execve ( char* path, char** argv, char** envp ) ; +FUNCTION: int _exit ( int status ) ; 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 ) ; From d2468ad9ed38e6aca0fc80691a5f662208de4a7f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Apr 2008 23:31:41 -0500 Subject: [PATCH 537/886] Add launcher error codes --- extra/io/unix/launcher/launcher.factor | 22 +++++++++++----------- extra/unix/unix.factor | 4 +++- 2 files changed, 14 insertions(+), 12 deletions(-) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index c104587c77..2736764665 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -66,18 +66,18 @@ USE: unix ?closed write-flags 2 redirect ] if ; -: spawn-process ( process -- * ) - [ - setup-priority - setup-redirection - current-directory get (normalize-path) cd - 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 "Exit failed" throw ] 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 current-process-handle ( -- handle ) getpid ; diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 3d4ce3cd48..9005cd2b2a 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -43,7 +43,9 @@ FUNCTION: int dup2 ( int oldd, int newd ) ; FUNCTION: int execv ( char* path, char** argv ) ; FUNCTION: int execvp ( char* path, char** argv ) ; FUNCTION: int execve ( char* path, char** argv, char** envp ) ; -FUNCTION: int _exit ( int status ) ; +: _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 ) ; From aade46d44874b2223a3d81eff411e1e80de98b05 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 6 Apr 2008 00:37:12 -0500 Subject: [PATCH 538/886] sqlite inheritance --- extra/db/sqlite/sqlite.factor | 44 +++++++++++++---------------------- 1 file changed, 16 insertions(+), 28 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 9b3185bcf2..d14403648d 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -5,61 +5,49 @@ hashtables io.files kernel math math.parser namespaces prettyprint sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators -io namespaces.lib ; -USE: tools.walker +io namespaces.lib accessors ; 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 - 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 < throwable-statement ; +! INSTANCE: sqlite-statement throwable-statement -TUPLE: sqlite-result-set has-more? ; +TUPLE: sqlite-result-set < result-set has-more? ; M: sqlite-db ( str in out -- obj ) ; M: sqlite-db ( 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 ; + f >>handle drop ; : sqlite-bind ( triples handle -- ) swap [ first3 sqlite-bind-type ] with each ; : reset-statement ( statement -- ) - sqlite-maybe-prepare - statement-handle sqlite-reset ; + sqlite-maybe-prepare handle>> sqlite-reset ; M: sqlite-statement bind-statement* ( statement -- ) sqlite-maybe-prepare @@ -104,7 +92,7 @@ M: sqlite-result-set more-rows? ( result-set -- ? ) M: sqlite-statement query-results ( query -- result-set ) sqlite-maybe-prepare - dup statement-handle sqlite-result-set + dup statement-handle sqlite-result-set construct-result-set dup advance-row ; M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; From 562ccb24f344789b0a1f9a3947803212bb745551 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Apr 2008 00:53:50 -0500 Subject: [PATCH 539/886] Fix Windows launcher issue --- extra/io/windows/launcher/launcher-tests.factor | 10 ++++++++++ extra/io/windows/launcher/launcher.factor | 15 ++++++++++++++- 2 files changed, 24 insertions(+), 1 deletion(-) create mode 100755 extra/io/windows/launcher/launcher-tests.factor diff --git a/extra/io/windows/launcher/launcher-tests.factor b/extra/io/windows/launcher/launcher-tests.factor new file mode 100755 index 0000000000..1dba8bd0ec --- /dev/null +++ b/extra/io/windows/launcher/launcher-tests.factor @@ -0,0 +1,10 @@ +IN: io.windows.launcher.tests +USING: tools.test io.windows.launcher ; + +[ "hello world" ] [ { "hello" "world" } join-arguments ] unit-test + +[ "bob \"mac arthur\"" ] [ { "bob" "mac arthur" } join-arguments ] unit-test + +[ "bob mac\\\\arthur" ] [ { "bob" "mac\\\\arthur" } join-arguments ] unit-test + +[ "bob \"mac arthur\\\\\"" ] [ { "bob" "mac arthur\\" } join-arguments ] unit-test diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 410e13d266..04e149d261 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -44,8 +44,21 @@ TUPLE: 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: \\ 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 ; From 0804c7e7af0f68696b57c4666838ff5e1da14414 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 6 Apr 2008 01:22:52 -0500 Subject: [PATCH 540/886] cleanup --- extra/db/sqlite/sqlite.factor | 46 +++++++++++++++++------------------ 1 file changed, 22 insertions(+), 24 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index d14403648d..e0930f3ba8 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -20,7 +20,6 @@ M: sqlite-db db-close ( handle -- ) sqlite-close ; M: sqlite-db dispose ( db -- ) dispose-db ; TUPLE: sqlite-statement < throwable-statement ; -! INSTANCE: sqlite-statement throwable-statement TUPLE: sqlite-result-set < result-set has-more? ; @@ -57,11 +56,11 @@ M: sqlite-statement bind-statement* ( statement -- ) M: sqlite-statement bind-tuple ( tuple statement -- ) [ - statement-in-params + in-params>> [ - [ sql-spec-column-name ":" prepend ] - [ sql-spec-slot-name rot get-slot-named ] - [ sql-spec-type ] tri 3array + [ column-name>> ":" prepend ] + [ slot-name>> rot get-slot-named ] + [ type>> ] tri 3array ] with map ] keep bind-statement ; @@ -71,28 +70,27 @@ M: sqlite-statement bind-tuple ( tuple statement -- ) dup zero? [ "last-id failed" throw ] when ; M: sqlite-db insert-tuple* ( tuple statement -- ) - execute-statement last-insert-id swap set-primary-key ; + execute-statement last-insert-id >>primary-key drop ; 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 construct-result-set + dup handle>> sqlite-result-set construct-result-set dup advance-row ; M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; @@ -107,9 +105,9 @@ 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>> t lookup-type 0% modifiers 0% ] interleave ");" 0% ] sqlite-make ; @@ -122,7 +120,7 @@ M: sqlite-db ( 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% @@ -133,11 +131,11 @@ M: sqlite-db ( tuple -- statement ) : where-primary-key% ( specs -- ) " where " 0% - find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ; + find-primary-key dup column-name>> 0% " = " 0% bind% ; : where-clause ( specs -- ) " where " 0% - [ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ; + [ " and " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave ; M: sqlite-db ( class -- statement ) [ @@ -145,7 +143,7 @@ M: sqlite-db ( class -- statement ) 0% " set " 0% dup remove-id - [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave where-primary-key% ] sqlite-make ; @@ -154,23 +152,23 @@ M: sqlite-db ( specs table -- sql ) "delete from " 0% 0% " where " 0% find-primary-key - dup sql-spec-column-name 0% " = " 0% bind% + dup column-name>> 0% " = " 0% bind% ] sqlite-make ; ! : select-interval ( interval name -- ) ; ! : select-sequence ( seq name -- ) ; M: sqlite-db bind% ( spec -- ) - dup 1, sql-spec-column-name ":" prepend 0% ; + dup 1, column-name>> ":" prepend 0% ; M: sqlite-db ( tuple class -- statement ) [ "select " 0% over [ ", " 0% ] - [ dup sql-spec-column-name 0% 2, ] interleave + [ dup column-name>> 0% 2, ] interleave " from " 0% 0% - [ sql-spec-slot-name swap get-slot-named ] with subset + [ column-name>> swap get-slot-named ] with subset dup empty? [ drop ] [ where-clause ] if ";" 0% ] sqlite-make ; From 49e3422d84569caf5836aafb068cce2fd1e52331 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Apr 2008 01:23:00 -0500 Subject: [PATCH 541/886] Comment out failing delegate unit tests since those features aren't used right now --- extra/delegate/delegate-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor index 497a6c5120..5e0abcd5ba 100644 --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -36,15 +36,15 @@ MIMIC: bee goodbye hello [ { t 1 0 } ] [ 1 0 bing ] unit-test [ 1 ] [ 1 0 f foo ] unit-test [ { t 1 0 } ] [ 1 0 f bar ] unit-test -[ { f 1 0 } ] [ f 1 0 bing ] unit-test +! [ { f 1 0 } ] [ f 1 0 bing ] unit-test [ 3 ] [ 1 0 2 whoa ] unit-test [ 3 ] [ 1 0 f 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 +! [ "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 From 22bf0625c6334eaa9174dd3d0414fd0affac2538 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Apr 2008 01:51:04 -0500 Subject: [PATCH 542/886] Fix 64-bit deploy tests --- extra/tools/deploy/deploy-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index f104fb0210..99e533f1c1 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -23,7 +23,7 @@ namespaces continuations layouts ; [ ] [ "sudoku" shake-and-bake ] unit-test [ t ] [ - 1500000 small-enough? + cell 8 = 30 15 ? 100000 * small-enough? ] unit-test [ ] [ "hello-ui" shake-and-bake ] unit-test @@ -34,13 +34,13 @@ namespaces continuations layouts ; ] unit-test [ t ] [ - 2000000 small-enough? + cell 8 = 40 20 ? 100000 * small-enough? ] unit-test [ ] [ "bunny" shake-and-bake ] unit-test [ t ] [ - 3000000 small-enough? + cell 8 = 50 30 ? 100000 * small-enough? ] unit-test [ ] [ From 4586200f83841bbac572c30301883e762818f08d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Apr 2008 03:30:10 -0500 Subject: [PATCH 543/886] Fix launcher failure on *BSD --- extra/io/unix/launcher/launcher.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 2736764665..82852f6311 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -31,7 +31,10 @@ USE: unix : 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 ; From 70573c01f07b1aecd9abe14fd44b0cd87f00a141 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 6 Apr 2008 14:33:01 -0500 Subject: [PATCH 544/886] comment out compiler error --- extra/db/mysql/lib/lib.factor | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/extra/db/mysql/lib/lib.factor b/extra/db/mysql/lib/lib.factor index 59d1b6ff3d..ca912f200d 100644 --- a/extra/db/mysql/lib/lib.factor +++ b/extra/db/mysql/lib/lib.factor @@ -18,16 +18,16 @@ TUPLE: mysql-result-set ; : 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 From d8dd8f967ec5c33d57fba093b4ad4580df413395 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 6 Apr 2008 16:22:05 -0500 Subject: [PATCH 545/886] Add frame-buffer --- extra/frame-buffer/frame-buffer.factor | 113 +++++++++++++++++++++++++ 1 file changed, 113 insertions(+) create mode 100644 extra/frame-buffer/frame-buffer.factor diff --git a/extra/frame-buffer/frame-buffer.factor b/extra/frame-buffer/frame-buffer.factor new file mode 100644 index 0000000000..eb9ada7d84 --- /dev/null +++ b/extra/frame-buffer/frame-buffer.factor @@ -0,0 +1,113 @@ + +USING: kernel alien.c-types combinators sequences splitting + opengl.gl ui.gadgets ui.render + math math.vectors accessors ; + +IN: 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]" + >>pixels ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: ( -- 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 * ] 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 ; + From ce895924bf0e70a7b7427fd6ff2b279623112f3c Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 6 Apr 2008 16:26:02 -0500 Subject: [PATCH 546/886] Move frame-buffer vocab --- extra/{ => ui/gadgets}/frame-buffer/frame-buffer.factor | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename extra/{ => ui/gadgets}/frame-buffer/frame-buffer.factor (100%) diff --git a/extra/frame-buffer/frame-buffer.factor b/extra/ui/gadgets/frame-buffer/frame-buffer.factor similarity index 100% rename from extra/frame-buffer/frame-buffer.factor rename to extra/ui/gadgets/frame-buffer/frame-buffer.factor From 9dbc39f5810f7ab91181501a0f36de4c178cb5c3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 6 Apr 2008 16:26:32 -0500 Subject: [PATCH 547/886] Set vocab name --- extra/ui/gadgets/frame-buffer/frame-buffer.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/gadgets/frame-buffer/frame-buffer.factor b/extra/ui/gadgets/frame-buffer/frame-buffer.factor index eb9ada7d84..4990254778 100644 --- a/extra/ui/gadgets/frame-buffer/frame-buffer.factor +++ b/extra/ui/gadgets/frame-buffer/frame-buffer.factor @@ -3,7 +3,7 @@ USING: kernel alien.c-types combinators sequences splitting opengl.gl ui.gadgets ui.render math math.vectors accessors ; -IN: frame-buffer +IN: ui.gadgets.frame-buffer ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 6508cf840ace232b4bc7df0a3089a8536b7b4de2 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 6 Apr 2008 16:27:21 -0500 Subject: [PATCH 548/886] newfx: Add a few words --- extra/newfx/newfx.factor | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index ae92f8f6c0..df826dc295 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -68,6 +68,29 @@ IN: newfx ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: 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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! 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 From 90f730256bf61056687c6a2825f3fa117e63eb85 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 6 Apr 2008 16:36:12 -0500 Subject: [PATCH 549/886] Add extra/processing --- extra/processing/color/color.factor | 22 ++ extra/processing/gadget/gadget.factor | 80 ++++++ extra/processing/processing.factor | 387 ++++++++++++++++++++++++++ 3 files changed, 489 insertions(+) create mode 100644 extra/processing/color/color.factor create mode 100644 extra/processing/gadget/gadget.factor create mode 100644 extra/processing/processing.factor diff --git a/extra/processing/color/color.factor b/extra/processing/color/color.factor new file mode 100644 index 0000000000..50d20fcf52 --- /dev/null +++ b/extra/processing/color/color.factor @@ -0,0 +1,22 @@ + +USING: kernel sequences ; + +IN: processing.color + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: rgba red green blue alpha ; + +C: rgba + +: ( r g b -- rgba ) 1 ; + +: ( gray -- rgba ) dup dup 1 ; + +: {rgb} ( seq -- rgba ) first3 ; + +! : hex>rgba ( hex -- rgba ) + +! : set-gl-color ( color -- ) +! { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ; + diff --git a/extra/processing/gadget/gadget.factor b/extra/processing/gadget/gadget.factor new file mode 100644 index 0000000000..8b78c43f00 --- /dev/null +++ b/extra/processing/gadget/gadget.factor @@ -0,0 +1,80 @@ + +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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: ( -- gadget ) + processing-gadget construct-empty + 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 diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor new file mode 100644 index 0000000000..acad02363b --- /dev/null +++ b/extra/processing/processing.factor @@ -0,0 +1,387 @@ + +USING: kernel namespaces threads combinators sequences arrays + math math.functions + opengl.gl opengl.glu vars multi-methods shuffle + ui + ui.gestures + ui.gadgets + combinators + combinators.lib + combinators.cleave + rewrite-closures fry accessors + processing.color + processing.gadget ; + +IN: processing + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +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 + + + 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 From d50d6a59efe5a21fe10c8093ed0e3afa22905b0c Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 6 Apr 2008 16:37:26 -0500 Subject: [PATCH 550/886] Add bubble-chamber demo --- extra/bubble-chamber/bubble-chamber.factor | 477 +++++++++++++++++++++ 1 file changed, 477 insertions(+) create mode 100644 extra/bubble-chamber/bubble-chamber.factor diff --git a/extra/bubble-chamber/bubble-chamber.factor b/extra/bubble-chamber/bubble-chamber.factor new file mode 100644 index 0000000000..ea8d309bdb --- /dev/null +++ b/extra/bubble-chamber/bubble-chamber.factor @@ -0,0 +1,477 @@ + +USING: kernel namespaces sequences combinators arrays threads + + math + math.libm + math.vectors + math.ranges + math.constants + math.functions + + ui + ui.gadgets + + random accessors multi-methods + combinators.cleave + vars locals + + newfx + + processing + processing.gadget + processing.color ; + +IN: bubble-chamber + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: 2random ( a b -- num ) 2dup swap - 100 / random ; + +: 1random ( b -- num ) 0 swap 2random ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: move-by ( obj delta -- obj ) over pos>> v+ >>pos ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: dim ( -- dim ) 1000 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: collision-theta + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: boom + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VARS: particles muons quarks hadrons axions ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: 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 } + } ; + +: good-color ( i -- color ) good-colors nth-of ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: x>> ( particle -- x ) pos>> first ; +: y>> ( particle -- x ) pos>> second ; + +: >>x ( particle x -- particle ) over y>> 2array >>pos ; +: >>y ( particle y -- particle ) over x>> swap 2array >>pos ; + +: x x>> ; +: y y>> ; + +: v+y ( seq y -- seq ) >r first2 r> + 2array ; +: v-y ( seq y -- seq ) >r first2 r> - 2array ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: out-of-bounds? ( particle -- particle ? ) + dup + { [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave + or or or ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: collide ( particle -- ) +GENERIC: move ( particle -- ) + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: muon pos speed theta speed-d theta-d theta-dd myc mya ; + +: ( -- muon ) + muon construct-empty + 0 0 2array >>pos + 0 >>speed + 0 >>speed-d + 0 >>theta + 0 >>theta-d + 0 >>theta-dd + 0 0 0 1 >>myc + 0 0 0 1 >>mya ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: collide { muon } + + dim 2 / dup 2array >>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 + + [ dup theta-dd>> abs 0.001 < ] + [ -0.1 0.1 2random >>theta-dd ] + [ ] + while + + dup theta>> pi + + 2 pi * / + good-colors length 1 - * + [ ] [ good-colors length >= ] [ 0 < ] tri or + [ drop ] + [ + [ good-color >>myc ] + [ good-colors length swap - 1 - good-color >>mya ] + bi + ] + if + + 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 } ] bi n*v + move-by + + [ ] [ theta>> ] [ theta-d>> ] tri + >>theta + [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d + [ ] [ speed>> ] [ speed-d>> ] tri - >>speed + + out-of-bounds? + [ collide ] + [ drop ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: quark pos vel speed theta speed-d theta-d theta-dd myc ; + +: ( -- quark ) + quark construct-empty + 0 0 2array >>pos + 0 0 2array >>vel + 0 >>speed + 0 >>speed-d + 0 >>theta + 0 >>theta-d + 0 >>theta-dd + 0 0 0 1 >>myc ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: collide { quark } + + dim 2 / dup 2array >>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 + + [ dup theta-dd>> abs 0.00001 < ] + [ -0.001 0.001 2random >>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 + + dup + [ speed>> ] [ theta>> { sin cos } ] bi n*v + >>vel + + [ ] [ theta>> ] [ theta-d>> ] tri + >>theta + [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d + [ ] [ speed>> ] [ speed-d>> ] tri * >>speed + + 1000 random 997 > + [ + dup speed>> neg >>speed + 2 over speed-d>> - >>speed-d + ] + when + + out-of-bounds? + [ collide ] + [ drop ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: hadron pos vel speed theta speed-d theta-d theta-dd myc ; + +: ( -- hadron ) + hadron construct-empty + 0 0 2array >>pos + 0 0 2array >>vel + 0 >>speed + 0 >>speed-d + 0 >>theta + 0 >>theta-d + 0 >>theta-dd + 0 0 0 1 >>myc ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: collide { hadron } + + dim 2 / dup 2array >>pos + 2 pi * 1random >>theta + 0.5 3.5 2random >>speed + + 0.996 1.001 2random >>speed-d + 0 >>theta-d + 0 >>theta-dd + + [ dup theta-dd>> abs 0.00001 < ] + [ -0.001 0.001 2random >>theta-dd ] + [ ] + while + + 0 1 0 >>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 + + dup + [ speed>> ] [ theta>> { sin cos } ] bi n*v + >>vel + + [ ] [ theta>> ] [ theta-d>> ] tri + >>theta + [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d + [ ] [ speed>> ] [ speed-d>> ] tri * >>speed + + 1000 random 997 > + [ + 1.0 >>speed-d + 0.00001 >>theta-dd + + 100 random 70 > + [ + dim 2 / dup 2array >>pos + dup collide + ] + when + ] + when + + out-of-bounds? + [ collide ] + [ drop ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: axion pos vel speed theta speed-d theta-d theta-dd ; + +: ( -- axion ) + axion construct-empty + 0 0 2array >>pos + 0 0 2array >>vel + 0 >>speed + 0 >>speed-d + 0 >>theta + 0 >>theta-d + 0 >>theta-dd ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: collide { axion } + + dim 2 / dup 2array >>pos + 2 pi * 1random >>theta + 1.0 6.0 2random >>speed + + 0.998 1.000 2random >>speed-d + 0 >>theta-d + 0 >>theta-dd + + [ dup theta-dd>> abs 0.00001 < ] + [ -0.001 0.001 2random >>theta-dd ] + [ ] + while + + drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: move { axion } + + { 0.06 0.59 } stroke + dup pos>> point + + 1 4 [a,b] + [| dy | + 1 30 dy 6 * - 255.0 / 2array stroke + dup pos>> 0 dy neg 2array v+ point + ] with-locals + each + + 1 4 [a,b] + [| dy | + 0 30 dy 6 * - 255.0 / 2array stroke + dup pos>> dy v+y point + ] with-locals + each + + dup vel>> move-by + + dup + [ speed>> ] [ theta>> { sin cos } ] bi n*v + >>vel + + [ ] [ theta>> ] [ theta-d>> ] tri + >>theta + [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d + [ ] [ speed>> ] [ speed-d>> ] tri * >>speed + + [ ] [ speed-d>> 0.9999 * ] bi >>speed-d + + 1000 random 996 > + [ + dup speed>> neg >>speed + dup speed-d>> neg 2 + >>speed-d + + 100 random 30 > + [ + dim 2 / dup 2array >>pos + collide + ] + [ drop ] + if + ] + [ drop ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! : draw ( -- ) + +! boom> +! [ particles> [ move ] each ] +! when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: 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 ] map >muons + 1300 [ drop ] map >quarks + 1000 [ drop ] map >hadrons + 111 [ drop ] 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 500 sleep run ] with-ui ; + +MAIN: go \ No newline at end of file From d81a4aa914ac947bf6f6e14029ac87ff9e330c5f Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 6 Apr 2008 19:03:00 -0500 Subject: [PATCH 551/886] Minor io.encodings.8-bit cleanup --- extra/io/encodings/8-bit/8-bit.factor | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index 259173fec4..04e8ee8569 100755 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -29,9 +29,10 @@ IN: io.encodings.8-bit { "mac-roman" "ROMAN" } } ; -: full-path ( file-name -- path ) +: encoding-file ( file-name -- stream ) "extra/io/encodings/8-bit/" ".TXT" - swapd 3append resource-path ; + swapd 3append resource-path + ascii ; : tail-if ( seq n -- newseq ) 2dup swap length <= [ tail ] [ drop ] if ; @@ -48,8 +49,8 @@ IN: io.encodings.8-bit : ch>byte ( assoc -- newassoc ) [ swap ] assoc-map >hashtable ; -: parse-file ( file-name -- byte>ch ch>byte ) - ascii file-lines process-contents +: parse-file ( path -- byte>ch ch>byte ) + lines process-contents [ byte>ch ] [ ch>byte ] bi ; TUPLE: 8-bit name decode encode ; @@ -71,13 +72,13 @@ M: 8-bit decode-char : make-8-bit ( word byte>ch ch>byte -- ) [ 8-bit construct-boa ] 2curry dupd curry define ; -: define-8-bit-encoding ( name path -- ) +: define-8-bit-encoding ( name stream -- ) >r in get create r> parse-file make-8-bit ; PRIVATE> [ "io.encodings.8-bit" in [ - mappings [ full-path define-8-bit-encoding ] assoc-each + mappings [ encoding-file define-8-bit-encoding ] assoc-each ] with-variable ] with-compilation-unit From 00d09d20e224bf2ec46dd4fc99bdfe906ff62b98 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 7 Apr 2008 12:07:44 +1200 Subject: [PATCH 552/886] Remove MATCH-VARS not used in pegs --- extra/peg/peg.factor | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 8d5d1c1560..3635abac84 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings fry namespaces math assocs shuffle - vectors arrays combinators.lib math.parser match + vectors arrays combinators.lib math.parser unicode.categories sequences.lib compiler.units parser words quotations effects memoize accessors locals effects splitting ; IN: peg @@ -265,8 +265,6 @@ SYMBOL: id TUPLE: token-parser symbol ; -MATCH-VARS: ?token ; - : parse-token ( input string -- result ) #! Parse the string, returning a parse result dup >r ?head-slice [ @@ -388,9 +386,6 @@ M: optional-parser (compile) ( parser -- quot ) p1>> compiled-parser 1quotation '[ @ check-optional ] ; TUPLE: semantic-parser p1 quot ; -MATCH-VARS: ?quot ; - -MATCH-VARS: ?parser ; : check-semantic ( result quot -- result ) over [ @@ -421,8 +416,6 @@ M: ensure-not-parser (compile) ( parser -- quot ) TUPLE: action-parser p1 quot ; -MATCH-VARS: ?action ; - : check-action ( result quot -- result ) over [ over ast>> swap call >>ast From 5a493c03849063bf54b6bce0b95406ea338bbf40 Mon Sep 17 00:00:00 2001 From: sheeple Date: Sun, 6 Apr 2008 19:28:47 -0500 Subject: [PATCH 553/886] symlink gdb to a working binary on freebsd, remove the special casing in code --- extra/tools/disassembler/disassembler.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index 5b835cd52f..39ee85b07a 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -26,8 +26,7 @@ M: pair make-disassemble-cmd M: method-spec make-disassemble-cmd first2 method make-disassemble-cmd ; -: gdb-binary ( -- string ) - os freebsd? "gdb66" "gdb" ? ; +: gdb-binary ( -- string ) "gdb" ; : run-gdb ( -- lines ) From a0939436272ac899f0d14f0939563a5cbfcf2d07 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 7 Apr 2008 12:50:07 +1200 Subject: [PATCH 554/886] Remove match from peg.parsers USING: list --- extra/peg/parsers/parsers.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 49035ea43c..3bbb61b846 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -1,7 +1,7 @@ ! 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 math.parser match + vectors arrays combinators.lib math.parser unicode.categories sequences.deep peg peg.private peg.search math.ranges words memoize ; IN: peg.parsers From 463a1991cae6c861e88ee54a3bb256f1b3ff5c44 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 7 Apr 2008 13:02:56 +1200 Subject: [PATCH 555/886] Fix peg help --- extra/peg/parsers/parsers-docs.factor | 4 ++-- extra/peg/peg-docs.factor | 4 ++-- extra/peg/peg.factor | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/peg/parsers/parsers-docs.factor b/extra/peg/parsers/parsers-docs.factor index d49f1158dd..d71fdaea3b 100755 --- a/extra/peg/parsers/parsers-docs.factor +++ b/extra/peg/parsers/parsers-docs.factor @@ -173,7 +173,7 @@ HELP: range-pattern "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 ;" "\"a\" \"_a-zA-Z\" range-pattern parse parse-result-ast 1string ." "\"a\"" } - { $example "USING: peg peg.parsers prettyprint ;" "\"0\" \"^0-9\" range-pattern parse ." "f" } + { $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" } } } ; diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index 5f200be78e..10e05a2512 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -104,8 +104,8 @@ HELP: semantic "Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with " "the AST produced by 'p1' on the stack returns true." } { $examples - { $example "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse" "f" } - { $example "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast " "67" } + { $example "USING: kernel math peg prettyprint ;" "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse ." "f" } + { $example "USING: kernel math peg prettyprint ;" "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast ." "67" } } ; HELP: ensure diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 3635abac84..ee9037ff25 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -241,7 +241,7 @@ GENERIC: (compile) ( parser -- quot ) : compiled-parse ( state word -- result ) swap [ execute ] with-packrat ; inline -: parse ( state parser -- result ) +: parse ( input parser -- result ) dup word? [ compile ] unless compiled-parse ; Date: Sun, 6 Apr 2008 20:09:20 -0500 Subject: [PATCH 556/886] Fix multi-methods --- extra/multi-methods/multi-methods.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 5ea19bc957..115432b14d 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -70,6 +70,9 @@ PREDICATE: method-body < word M: method-body stack-effect "multi-method" word-prop method-generic stack-effect ; +M: method-body crossref? + drop t ; + : method-word-name ( classes generic -- string ) [ word-name % From f5d7f8b91727f774d2437454e63824984df35184 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Apr 2008 20:09:31 -0500 Subject: [PATCH 557/886] Doc fix --- core/io/files/files-docs.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 1dd96a13fc..e3f86c079d 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -7,14 +7,15 @@ ARTICLE: "file-streams" "Reading and writing files" { $subsection } { $subsection } { $subsection } +"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 set-file-contents } -{ $subsection file-contents } -{ $subsection set-file-lines } -{ $subsection file-lines } ; +{ $subsection with-file-appender } ; ARTICLE: "pathnames" "Pathname manipulation" "Pathname manipulation:" From 719376e412804f1286482ff32cf3aaf1889f524d Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 7 Apr 2008 13:17:09 +1200 Subject: [PATCH 558/886] Remove w-c-u from ebnf transform --- extra/peg/ebnf/ebnf.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index e5787e6cf8..56f88fc866 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -318,11 +318,11 @@ M: object build-locals ( code ast -- ) M: ebnf-action (transform) ( ast -- parser ) [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals - string-lines [ parse-lines ] with-compilation-unit action ; + string-lines parse-lines action ; M: ebnf-semantic (transform) ( ast -- parser ) [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals - string-lines [ parse-lines ] with-compilation-unit semantic ; + string-lines parse-lines semantic ; M: ebnf-var (transform) ( ast -- parser ) parser>> (transform) ; From 8f7f1228d35a1131d18d7f437424a5739a42d187 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 6 Apr 2008 20:31:40 -0500 Subject: [PATCH 559/886] Add processing.gallery.trails --- extra/processing/gallery/trails/trails.factor | 62 +++++++++++++++++++ 1 file changed, 62 insertions(+) create mode 100644 extra/processing/gallery/trails/trails.factor diff --git a/extra/processing/gallery/trails/trails.factor b/extra/processing/gallery/trails/trails.factor new file mode 100644 index 0000000000..f0a8889fbf --- /dev/null +++ b/extra/processing/gallery/trails/trails.factor @@ -0,0 +1,62 @@ + +USING: kernel arrays sequences math qualified circular processing ui ; + +IN: processing.gallery.trails + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! Example 33-15 from the Processing book + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +QUALIFIED: circular + +: push-circular ( seq elt -- seq ) over circular:push-circular ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: each-percent ( seq quot -- ) + >r + dup length + dup [ / ] curry + [ 1+ ] swap compose + r> compose + 2each ; inline + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: point-list ( n -- seq ) [ drop 0 0 2array ] map ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: 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 From 73a914cab7e299705e2a74d946b2b91c9ded605f Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 6 Apr 2008 20:33:45 -0500 Subject: [PATCH 560/886] Move bubble-chamber to processing.gallery.bubble-chamber --- .../gallery}/bubble-chamber/bubble-chamber.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) rename extra/{ => processing/gallery}/bubble-chamber/bubble-chamber.factor (99%) diff --git a/extra/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor similarity index 99% rename from extra/bubble-chamber/bubble-chamber.factor rename to extra/processing/gallery/bubble-chamber/bubble-chamber.factor index ea8d309bdb..708e50fb12 100644 --- a/extra/bubble-chamber/bubble-chamber.factor +++ b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor @@ -472,6 +472,6 @@ METHOD: move { axion } ; -: go ( -- ) [ bubble-chamber 500 sleep run ] with-ui ; +: go ( -- ) [ bubble-chamber run ] with-ui ; MAIN: go \ No newline at end of file From 6c74f33edb3bed776bcb332bf7f16bb17cc220be Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 6 Apr 2008 20:34:53 -0500 Subject: [PATCH 561/886] bubble-chamber: Fix IN: --- extra/processing/gallery/bubble-chamber/bubble-chamber.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor index 708e50fb12..c6e000e74f 100644 --- a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor +++ b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor @@ -21,7 +21,7 @@ USING: kernel namespaces sequences combinators arrays threads processing.gadget processing.color ; -IN: bubble-chamber +IN: processing.gallery.bubble-chamber ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From ddb1749c57743c25d7667c9484fa854ee98abf50 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 6 Apr 2008 21:07:21 -0500 Subject: [PATCH 562/886] ERROR: should be inside the IN: --- extra/opengl/gl/extensions/extensions.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor index b8ac396c2f..20929fb410 100644 --- a/extra/opengl/gl/extensions/extensions.factor +++ b/extra/opengl/gl/extensions/extensions.factor @@ -1,6 +1,7 @@ USING: alien alien.syntax combinators kernel parser sequences system words namespaces hashtables init math arrays assocs continuations ; +IN: opengl.gl.extensions ERROR: unknown-gl-platform ; << { @@ -9,7 +10,6 @@ ERROR: unknown-gl-platform ; { [ os unix? ] [ "opengl.gl.unix" ] } { [ t ] [ unknown-gl-platform ] } } cond use+ >> -IN: opengl.gl.extensions SYMBOL: +gl-function-number-counter+ SYMBOL: +gl-function-pointers+ From a641c6d332e36910239a6a269e299a231f422d18 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 7 Apr 2008 14:39:18 +1200 Subject: [PATCH 563/886] Add \r to ebnf escape rules --- extra/peg/ebnf/ebnf.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 56f88fc866..8bf0475da5 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -361,7 +361,11 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) [ compiled-parse ] curry [ with-scope ] curry ; : replace-escapes ( string -- string ) - "\\t" token [ drop "\t" ] action "\\n" token [ drop "\n" ] action 2choice replace ; + [ + "\\t" token [ drop "\t" ] action , + "\\n" token [ drop "\n" ] action , + "\\r" token [ drop "\r" ] action , + ] choice* replace ; : [EBNF "EBNF]" parse-multiline-string replace-escapes ebnf>quot nip parsed ; parsing From 1518d631150a969041095d71cc8381bff6157b47 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Apr 2008 22:04:31 -0500 Subject: [PATCH 564/886] Fix Windows launcher resource leak --- extra/io/windows/nt/launcher/launcher-tests.factor | 13 ++++++++++++- extra/io/windows/nt/launcher/launcher.factor | 2 +- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/extra/io/windows/nt/launcher/launcher-tests.factor b/extra/io/windows/nt/launcher/launcher-tests.factor index fac6471b8c..8b13b9b3b9 100755 --- a/extra/io/windows/nt/launcher/launcher-tests.factor +++ b/extra/io/windows/nt/launcher/launcher-tests.factor @@ -1,7 +1,7 @@ IN: io.windows.launcher.nt.tests USING: io.launcher tools.test calendar accessors namespaces kernel system arrays io io.files io.encodings.ascii -sequences parser assocs hashtables ; +sequences parser assocs hashtables math ; [ ] [ @@ -129,3 +129,14 @@ sequences parser assocs hashtables ; "HOME" swap at "XXX" = ] unit-test + +2 [ + [ ] [ + + "cmd.exe /c dir" >>command + "dir.txt" temp-file >>stdout + try-process + ] unit-test + + [ ] [ "dir.txt" temp-file delete-file ] unit-test +] times diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index a01ba4698e..97de248d24 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -39,7 +39,7 @@ IN: io.windows.nt.launcher 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 ; From 225a0fb781f281c2c581bacac5c4989fc2ba7d7d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Apr 2008 23:31:53 -0500 Subject: [PATCH 565/886] Fix Windows crash with set-os-envs --- core/bootstrap/primitives.factor | 1 + core/inference/known-words/known-words.factor | 2 + core/kernel/kernel-tests.factor | 9 + vm/errors.c | 6 + vm/errors.h | 2 + vm/errors.s | 687 ++++++++ vm/os-windows.c | 2 +- vm/primitives.c | 1 + vm/run.s | 1511 +++++++++++++++++ 9 files changed, 2220 insertions(+), 1 deletion(-) create mode 100644 vm/errors.s create mode 100644 vm/run.s diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 5836b4d3c5..233de6f4ee 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -737,6 +737,7 @@ define-builtin { "resize-bit-array" "bit-arrays" } { "resize-float-array" "float-arrays" } { "dll-valid?" "alien" } + { "unimplemented" "kernel.private" } } dup length [ >r first2 r> make-primitive ] 2each diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 99737e0ac5..8f505c21a1 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -594,3 +594,5 @@ set-primitive-effect \ dll-valid? { object } { object } set-primitive-effect \ modify-code-heap { array object } { } set-primitive-effect + +\ unimplemented { } { } set-primitive-effect diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 3c40984d7a..4b129ad59d 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -108,3 +108,12 @@ IN: kernel.tests 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 diff --git a/vm/errors.c b/vm/errors.c index 27158cbf44..6d99d34766 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -145,3 +145,9 @@ DEFINE_PRIMITIVE(call_clear) { throw_impl(dpop(),stack_chain->callstack_bottom); } + +/* For testing purposes */ +DEFINE_PRIMITIVE(unimplemented) +{ + not_implemented_error(); +} diff --git a/vm/errors.h b/vm/errors.h index 747a3415ba..227fed9228 100755 --- a/vm/errors.h +++ b/vm/errors.h @@ -55,3 +55,5 @@ void *signal_callstack_top; void memory_signal_handler_impl(void); void divide_by_zero_signal_handler_impl(void); void misc_signal_handler_impl(void); + +DECLARE_PRIMITIVE(unimplemented); diff --git a/vm/errors.s b/vm/errors.s new file mode 100644 index 0000000000..d6b3bdb6e5 --- /dev/null +++ b/vm/errors.s @@ -0,0 +1,687 @@ + .file "errors.c" + .section .rdata,"dr" +LC0: + .ascii "fatal_error: %s %lx\12\0" + .text +.globl _fatal_error + .def _fatal_error; .scl 2; .type 32; .endef +_fatal_error: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call ___getreent + movl %eax, %edx + movl 12(%ebp), %eax + movl %eax, 12(%esp) + movl 8(%ebp), %eax + movl %eax, 8(%esp) + movl $LC0, 4(%esp) + movl 12(%edx), %eax + movl %eax, (%esp) + call _fprintf + movl $1, (%esp) + call _exit + .section .rdata,"dr" + .align 4 +LC1: + .ascii "You have triggered a bug in Factor. Please report.\12\0" +LC2: + .ascii "critical_error: %s %lx\12\0" + .text +.globl _critical_error + .def _critical_error; .scl 2; .type 32; .endef +_critical_error: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call ___getreent + movl $LC1, 4(%esp) + movl 12(%eax), %eax + movl %eax, (%esp) + call _fprintf + call ___getreent + movl %eax, %edx + movl 12(%ebp), %eax + movl %eax, 12(%esp) + movl 8(%ebp), %eax + movl %eax, 8(%esp) + movl $LC2, 4(%esp) + movl 12(%edx), %eax + movl %eax, (%esp) + call _fprintf + call _factorbug + leave + ret + .section .rdata,"dr" +LC3: + .ascii "early_error: \0" +LC4: + .ascii "\12\0" + .text +.globl _throw_error + .def _throw_error; .scl 2; .type 32; .endef +_throw_error: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + cmpl $7, _userenv+20 + je L4 + movb $0, _gc_off + movl _gc_locals_region, %eax + movl (%eax), %eax + subl $4, %eax + movl %eax, _gc_locals + movl _extra_roots_region, %eax + movl (%eax), %eax + subl $4, %eax + movl %eax, _extra_roots + call _fix_stacks + movl 8(%ebp), %eax + movl %eax, (%esp) + call _dpush + cmpl $0, 12(%ebp) + je L5 + movl _stack_chain, %eax + movl 4(%eax), %eax + movl %eax, 4(%esp) + movl 12(%ebp), %eax + movl %eax, (%esp) + call _fix_callstack_top + movl %eax, 12(%ebp) + jmp L6 +L5: + movl _stack_chain, %eax + movl (%eax), %eax + movl %eax, 12(%ebp) +L6: + movl 12(%ebp), %edx + movl _userenv+20, %eax + call _throw_impl + jmp L3 +L4: + call ___getreent + movl $LC1, 4(%esp) + movl 12(%eax), %eax + movl %eax, (%esp) + call _fprintf + call ___getreent + movl $LC3, 4(%esp) + movl 12(%eax), %eax + movl %eax, (%esp) + call _fprintf + movl 8(%ebp), %eax + movl %eax, (%esp) + call _print_obj + call ___getreent + movl $LC4, 4(%esp) + movl 12(%eax), %eax + movl %eax, (%esp) + call _fprintf + call _factorbug +L3: + leave + ret + .def _dpush; .scl 3; .type 32; .endef +_dpush: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + addl $4, %esi + movl 8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + leave + ret + .def _put; .scl 3; .type 32; .endef +_put: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %edx + movl 12(%ebp), %eax + movl %eax, (%edx) + popl %ebp + ret +.globl _general_error + .def _general_error; .scl 2; .type 32; .endef +_general_error: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl 8(%ebp), %eax + movl %eax, (%esp) + call _tag_fixnum + movl %eax, %edx + movl 16(%ebp), %eax + movl %eax, 12(%esp) + movl 12(%ebp), %eax + movl %eax, 8(%esp) + movl %edx, 4(%esp) + movl _userenv+24, %eax + movl %eax, (%esp) + call _allot_array_4 + movl %eax, %edx + movl 20(%ebp), %eax + movl %eax, 4(%esp) + movl %edx, (%esp) + call _throw_error + leave + ret + .def _tag_fixnum; .scl 3; .type 32; .endef +_tag_fixnum: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + sall $3, %eax + andl $-8, %eax + popl %ebp + ret +.globl _type_error + .def _type_error; .scl 2; .type 32; .endef +_type_error: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl 8(%ebp), %eax + movl %eax, (%esp) + call _tag_fixnum + movl %eax, %edx + movl $0, 12(%esp) + movl 12(%ebp), %eax + movl %eax, 8(%esp) + movl %edx, 4(%esp) + movl $3, (%esp) + call _general_error + leave + ret +.globl _not_implemented_error + .def _not_implemented_error; .scl 2; .type 32; .endef +_not_implemented_error: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl $0, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $2, (%esp) + call _general_error + leave + ret +.globl _in_page + .def _in_page; .scl 2; .type 32; .endef +_in_page: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _getpagesize + movl %eax, -4(%ebp) + movl 16(%ebp), %edx + leal 12(%ebp), %eax + addl %edx, (%eax) + movl 20(%ebp), %eax + movl %eax, %edx + imull -4(%ebp), %edx + leal 12(%ebp), %eax + addl %edx, (%eax) + movb $0, -5(%ebp) + movl 8(%ebp), %eax + cmpl 12(%ebp), %eax + jb L15 + movl -4(%ebp), %eax + addl 12(%ebp), %eax + cmpl 8(%ebp), %eax + jb L15 + movb $1, -5(%ebp) +L15: + movzbl -5(%ebp), %eax + leave + ret + .section .rdata,"dr" + .align 4 +LC5: + .ascii "allot_object() missed GC check\0" +LC6: + .ascii "gc locals underflow\0" +LC7: + .ascii "gc locals overflow\0" +LC8: + .ascii "extra roots underflow\0" +LC9: + .ascii "extra roots overflow\0" + .text +.globl _memory_protection_error + .def _memory_protection_error; .scl 2; .type 32; .endef +_memory_protection_error: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl $-1, 12(%esp) + movl $0, 8(%esp) + movl _stack_chain, %eax + movl 24(%eax), %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L17 + movl 12(%ebp), %eax + movl %eax, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $11, (%esp) + call _general_error + jmp L16 +L17: + movl $0, 12(%esp) + movl _ds_size, %eax + movl %eax, 8(%esp) + movl _stack_chain, %eax + movl 24(%eax), %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L19 + movl 12(%ebp), %eax + movl %eax, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $12, (%esp) + call _general_error + jmp L16 +L19: + movl $-1, 12(%esp) + movl $0, 8(%esp) + movl _stack_chain, %eax + movl 28(%eax), %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L21 + movl 12(%ebp), %eax + movl %eax, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $13, (%esp) + call _general_error + jmp L16 +L21: + movl $0, 12(%esp) + movl _rs_size, %eax + movl %eax, 8(%esp) + movl _stack_chain, %eax + movl 28(%eax), %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L23 + movl 12(%ebp), %eax + movl %eax, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $14, (%esp) + call _general_error + jmp L16 +L23: + movl $0, 12(%esp) + movl $0, 8(%esp) + movl _nursery, %eax + movl 12(%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L25 + movl $0, 4(%esp) + movl $LC5, (%esp) + call _critical_error + jmp L16 +L25: + movl $-1, 12(%esp) + movl $0, 8(%esp) + movl _gc_locals_region, %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L27 + movl $0, 4(%esp) + movl $LC6, (%esp) + call _critical_error + jmp L16 +L27: + movl $0, 12(%esp) + movl $0, 8(%esp) + movl _gc_locals_region, %eax + movl 8(%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L29 + movl $0, 4(%esp) + movl $LC7, (%esp) + call _critical_error + jmp L16 +L29: + movl $-1, 12(%esp) + movl $0, 8(%esp) + movl _extra_roots_region, %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L31 + movl $0, 4(%esp) + movl $LC8, (%esp) + call _critical_error + jmp L16 +L31: + movl $0, 12(%esp) + movl $0, 8(%esp) + movl _extra_roots_region, %eax + movl 8(%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L33 + movl $0, 4(%esp) + movl $LC9, (%esp) + call _critical_error + jmp L16 +L33: + movl 8(%ebp), %eax + movl %eax, (%esp) + call _allot_cell + movl %eax, %edx + movl 12(%ebp), %eax + movl %eax, 12(%esp) + movl $7, 8(%esp) + movl %edx, 4(%esp) + movl $15, (%esp) + call _general_error +L16: + leave + ret + .def _allot_cell; .scl 3; .type 32; .endef +_allot_cell: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + cmpl $268435455, 8(%ebp) + jbe L36 + movl 8(%ebp), %eax + movl %eax, (%esp) + call _cell_to_bignum + movl %eax, (%esp) + call _tag_bignum + movl %eax, -4(%ebp) + jmp L35 +L36: + movl 8(%ebp), %eax + movl %eax, (%esp) + call _tag_fixnum + movl %eax, -4(%ebp) +L35: + movl -4(%ebp), %eax + leave + ret + .def _tag_bignum; .scl 3; .type 32; .endef +_tag_bignum: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + andl $-8, %eax + orl $1, %eax + popl %ebp + ret +.globl _signal_error + .def _signal_error; .scl 2; .type 32; .endef +_signal_error: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl 8(%ebp), %eax + movl %eax, (%esp) + call _tag_fixnum + movl %eax, %edx + movl 12(%ebp), %eax + movl %eax, 12(%esp) + movl $7, 8(%esp) + movl %edx, 4(%esp) + movl $5, (%esp) + call _general_error + leave + ret +.globl _divide_by_zero_error + .def _divide_by_zero_error; .scl 2; .type 32; .endef +_divide_by_zero_error: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl 8(%ebp), %eax + movl %eax, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $4, (%esp) + call _general_error + leave + ret +.globl _memory_signal_handler_impl + .def _memory_signal_handler_impl; .scl 2; .type 32; .endef +_memory_signal_handler_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl _signal_callstack_top, %eax + movl %eax, 4(%esp) + movl _signal_fault_addr, %eax + movl %eax, (%esp) + call _memory_protection_error + leave + ret +.globl _divide_by_zero_signal_handler_impl + .def _divide_by_zero_signal_handler_impl; .scl 2; .type 32; .endef +_divide_by_zero_signal_handler_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl _signal_callstack_top, %eax + movl %eax, (%esp) + call _divide_by_zero_error + leave + ret +.globl _misc_signal_handler_impl + .def _misc_signal_handler_impl; .scl 2; .type 32; .endef +_misc_signal_handler_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl _signal_callstack_top, %eax + movl %eax, 4(%esp) + movl _signal_number, %eax + movl %eax, (%esp) + call _signal_error + leave + ret +.globl _primitive_throw + .def _primitive_throw; .scl 2; .type 32; .endef +_primitive_throw: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_throw_impl + leave + ret + .def _primitive_throw_impl; .scl 3; .type 32; .endef +_primitive_throw_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + call _dpop + movl %eax, %ecx + movl _stack_chain, %eax + movl (%eax), %edx + movl %ecx, %eax + call _throw_impl + leave + ret + .def _dpop; .scl 3; .type 32; .endef +_dpop: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %esi, (%esp) + call _get + movl %eax, -4(%ebp) + subl $4, %esi + movl -4(%ebp), %eax + leave + ret + .def _get; .scl 3; .type 32; .endef +_get: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + movl (%eax), %eax + popl %ebp + ret +.globl _primitive_call_clear + .def _primitive_call_clear; .scl 2; .type 32; .endef +_primitive_call_clear: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_call_clear_impl + leave + ret + .def _primitive_call_clear_impl; .scl 3; .type 32; .endef +_primitive_call_clear_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl _stack_chain, %edx + movl 4(%edx), %edx + call _throw_impl + leave + ret +.globl _primitive_unimplemented2 + .def _primitive_unimplemented2; .scl 2; .type 32; .endef +_primitive_unimplemented2: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + call _not_implemented_error + leave + ret +.globl _primitive_unimplemented + .def _primitive_unimplemented; .scl 2; .type 32; .endef +_primitive_unimplemented: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_unimplemented_impl + leave + ret + .def _primitive_unimplemented_impl; .scl 3; .type 32; .endef +_primitive_unimplemented_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _not_implemented_error + leave + ret + .comm _console_open, 16 # 1 + .comm _userenv, 256 # 256 + .comm _T, 16 # 4 + .comm _stack_chain, 16 # 4 + .comm _ds_size, 16 # 4 + .comm _rs_size, 16 # 4 + .comm _stage2, 16 # 1 + .comm _profiling_p, 16 # 1 + .comm _signal_number, 16 # 4 + .comm _signal_fault_addr, 16 # 4 + .comm _signal_callstack_top, 16 # 4 + .comm _secure_gc, 16 # 1 + .comm _data_heap, 16 # 4 + .comm _cards_offset, 16 # 4 + .comm _newspace, 16 # 4 + .comm _nursery, 16 # 4 + .comm _gc_time, 16 # 8 + .comm _nursery_collections, 16 # 4 + .comm _aging_collections, 16 # 4 + .comm _cards_scanned, 16 # 4 + .comm _performing_gc, 16 # 1 + .comm _collecting_gen, 16 # 4 + .comm _collecting_aging_again, 16 # 1 + .comm _last_code_heap_scan, 16 # 4 + .comm _growing_data_heap, 16 # 1 + .comm _old_data_heap, 16 # 4 + .comm _gc_jmp, 208 # 208 + .comm _heap_scan_ptr, 16 # 4 + .comm _gc_off, 16 # 1 + .comm _gc_locals_region, 16 # 4 + .comm _gc_locals, 16 # 4 + .comm _extra_roots_region, 16 # 4 + .comm _extra_roots, 16 # 4 + .comm _bignum_zero, 16 # 4 + .comm _bignum_pos_one, 16 # 4 + .comm _bignum_neg_one, 16 # 4 + .comm _code_heap, 16 # 8 + .comm _data_relocation_base, 16 # 4 + .comm _code_relocation_base, 16 # 4 + .comm _posix_argc, 16 # 4 + .comm _posix_argv, 16 # 4 + .def _save_callstack_top; .scl 3; .type 32; .endef + .def _getpagesize; .scl 3; .type 32; .endef + .def _allot_array_4; .scl 3; .type 32; .endef + .def _print_obj; .scl 3; .type 32; .endef + .def _throw_impl; .scl 3; .type 32; .endef + .def _fix_callstack_top; .scl 3; .type 32; .endef + .def _fix_stacks; .scl 3; .type 32; .endef + .def _factorbug; .scl 3; .type 32; .endef + .def _exit; .scl 3; .type 32; .endef + .def ___getreent; .scl 3; .type 32; .endef + .def _fprintf; .scl 3; .type 32; .endef + .def _critical_error; .scl 3; .type 32; .endef + .def _type_error; .scl 3; .type 32; .endef + .section .drectve + + .ascii " -export:nursery,data" + .ascii " -export:cards_offset,data" + .ascii " -export:stack_chain,data" + .ascii " -export:userenv,data" diff --git a/vm/os-windows.c b/vm/os-windows.c index 1be41f8b57..664df9e774 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -215,7 +215,7 @@ void sleep_millis(DWORD msec) Sleep(msec); } -DECLARE_PRIMITIVE(set_os_envs) +DEFINE_PRIMITIVE(set_os_envs) { not_implemented_error(); } diff --git a/vm/primitives.c b/vm/primitives.c index 038a7d84a5..533fcebc9a 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -187,4 +187,5 @@ void *primitives[] = { primitive_resize_bit_array, primitive_resize_float_array, primitive_dll_validp, + primitive_unimplemented, }; diff --git a/vm/run.s b/vm/run.s new file mode 100644 index 0000000000..78b2adac84 --- /dev/null +++ b/vm/run.s @@ -0,0 +1,1511 @@ + .file "run.c" + .text +.globl _reset_datastack + .def _reset_datastack; .scl 2; .type 32; .endef +_reset_datastack: + pushl %ebp + movl %esp, %ebp + movl _stack_chain, %eax + movl 24(%eax), %eax + movl (%eax), %esi + subl $4, %esi + popl %ebp + ret +.globl _reset_retainstack + .def _reset_retainstack; .scl 2; .type 32; .endef +_reset_retainstack: + pushl %ebp + movl %esp, %ebp + movl _stack_chain, %eax + movl 28(%eax), %eax + movl (%eax), %edi + subl $4, %edi + popl %ebp + ret +.globl _fix_stacks + .def _fix_stacks; .scl 2; .type 32; .endef +_fix_stacks: + pushl %ebp + movl %esp, %ebp + leal 4(%esi), %eax + movl _stack_chain, %edx + movl 24(%edx), %edx + cmpl (%edx), %eax + jb L5 + leal 256(%esi), %eax + movl _stack_chain, %edx + movl 24(%edx), %edx + cmpl 8(%edx), %eax + jae L5 + jmp L4 +L5: + call _reset_datastack +L4: + leal 4(%edi), %eax + movl _stack_chain, %edx + movl 28(%edx), %edx + cmpl (%edx), %eax + jb L7 + leal 256(%edi), %eax + movl _stack_chain, %edx + movl 28(%edx), %edx + cmpl 8(%edx), %eax + jae L7 + jmp L3 +L7: + call _reset_retainstack +L3: + popl %ebp + ret +.globl _save_stacks + .def _save_stacks; .scl 2; .type 32; .endef +_save_stacks: + pushl %ebp + movl %esp, %ebp + cmpl $0, _stack_chain + je L8 + movl _stack_chain, %eax + movl %esi, 8(%eax) + movl _stack_chain, %eax + movl %edi, 12(%eax) +L8: + popl %ebp + ret +.globl _nest_stacks + .def _nest_stacks; .scl 2; .type 32; .endef +_nest_stacks: + pushl %ebp + movl %esp, %ebp + pushl %ebx + subl $20, %esp + movl $44, (%esp) + call _safe_malloc + movl %eax, -8(%ebp) + movl -8(%ebp), %eax + movl $-1, 4(%eax) + movl -8(%ebp), %eax + movl $-1, (%eax) + movl -8(%ebp), %eax + movl %esi, 16(%eax) + movl -8(%ebp), %eax + movl %edi, 20(%eax) + movl -8(%ebp), %edx + movl _userenv+8, %eax + movl %eax, 36(%edx) + movl -8(%ebp), %edx + movl _userenv+4, %eax + movl %eax, 32(%edx) + movl -8(%ebp), %ebx + movl _ds_size, %eax + movl %eax, (%esp) + call _alloc_segment + movl %eax, 24(%ebx) + movl -8(%ebp), %ebx + movl _rs_size, %eax + movl %eax, (%esp) + call _alloc_segment + movl %eax, 28(%ebx) + movl -8(%ebp), %edx + movl _stack_chain, %eax + movl %eax, 40(%edx) + movl -8(%ebp), %eax + movl %eax, _stack_chain + call _reset_datastack + call _reset_retainstack + addl $20, %esp + popl %ebx + popl %ebp + ret +.globl _unnest_stacks + .def _unnest_stacks; .scl 2; .type 32; .endef +_unnest_stacks: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl _stack_chain, %eax + movl 24(%eax), %eax + movl %eax, (%esp) + call _dealloc_segment + movl _stack_chain, %eax + movl 28(%eax), %eax + movl %eax, (%esp) + call _dealloc_segment + movl _stack_chain, %eax + movl 16(%eax), %esi + movl _stack_chain, %eax + movl 20(%eax), %edi + movl _stack_chain, %eax + movl 36(%eax), %eax + movl %eax, _userenv+8 + movl _stack_chain, %eax + movl 32(%eax), %eax + movl %eax, _userenv+4 + movl _stack_chain, %eax + movl %eax, -4(%ebp) + movl -4(%ebp), %eax + movl 40(%eax), %eax + movl %eax, _stack_chain + movl -4(%ebp), %eax + movl %eax, (%esp) + call _free + leave + ret +.globl _init_stacks + .def _init_stacks; .scl 2; .type 32; .endef +_init_stacks: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + movl %eax, _ds_size + movl 12(%ebp), %eax + movl %eax, _rs_size + movl $0, _stack_chain + popl %ebp + ret +.globl _primitive_drop + .def _primitive_drop; .scl 2; .type 32; .endef +_primitive_drop: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_drop_impl + leave + ret + .def _primitive_drop_impl; .scl 3; .type 32; .endef +_primitive_drop_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + leave + ret + .def _dpop; .scl 3; .type 32; .endef +_dpop: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %esi, (%esp) + call _get + movl %eax, -4(%ebp) + subl $4, %esi + movl -4(%ebp), %eax + leave + ret + .def _get; .scl 3; .type 32; .endef +_get: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + movl (%eax), %eax + popl %ebp + ret +.globl _primitive_2drop + .def _primitive_2drop; .scl 2; .type 32; .endef +_primitive_2drop: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_2drop_impl + leave + ret + .def _primitive_2drop_impl; .scl 3; .type 32; .endef +_primitive_2drop_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esi + popl %ebp + ret +.globl _primitive_3drop + .def _primitive_3drop; .scl 2; .type 32; .endef +_primitive_3drop: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_3drop_impl + leave + ret + .def _primitive_3drop_impl; .scl 3; .type 32; .endef +_primitive_3drop_impl: + pushl %ebp + movl %esp, %ebp + subl $12, %esi + popl %ebp + ret +.globl _primitive_dup + .def _primitive_dup; .scl 2; .type 32; .endef +_primitive_dup: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_dup_impl + leave + ret + .def _primitive_dup_impl; .scl 3; .type 32; .endef +_primitive_dup_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpeek + movl %eax, (%esp) + call _dpush + leave + ret + .def _dpush; .scl 3; .type 32; .endef +_dpush: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + addl $4, %esi + movl 8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + leave + ret + .def _put; .scl 3; .type 32; .endef +_put: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %edx + movl 12(%ebp), %eax + movl %eax, (%edx) + popl %ebp + ret + .def _dpeek; .scl 3; .type 32; .endef +_dpeek: + pushl %ebp + movl %esp, %ebp + subl $4, %esp + movl %esi, (%esp) + call _get + leave + ret +.globl _primitive_2dup + .def _primitive_2dup; .scl 2; .type 32; .endef +_primitive_2dup: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_2dup_impl + leave + ret + .def _primitive_2dup_impl; .scl 3; .type 32; .endef +_primitive_2dup_impl: + pushl %ebp + movl %esp, %ebp + subl $16, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + addl $8, %esi + movl -8(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + leave + ret +.globl _primitive_3dup + .def _primitive_3dup; .scl 2; .type 32; .endef +_primitive_3dup: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_3dup_impl + leave + ret + .def _primitive_3dup_impl; .scl 3; .type 32; .endef +_primitive_3dup_impl: + pushl %ebp + movl %esp, %ebp + subl $20, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -12(%ebp) + addl $12, %esi + movl -4(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -8(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -12(%ebp), %eax + movl %eax, 4(%esp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _put + leave + ret +.globl _primitive_rot + .def _primitive_rot; .scl 2; .type 32; .endef +_primitive_rot: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_rot_impl + leave + ret + .def _primitive_rot_impl; .scl 3; .type 32; .endef +_primitive_rot_impl: + pushl %ebp + movl %esp, %ebp + subl $20, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -12(%ebp) + movl -12(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -8(%ebp), %eax + movl %eax, 4(%esp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _put + leave + ret +.globl _primitive__rot + .def _primitive__rot; .scl 2; .type 32; .endef +_primitive__rot: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive__rot_impl + leave + ret + .def _primitive__rot_impl; .scl 3; .type 32; .endef +_primitive__rot_impl: + pushl %ebp + movl %esp, %ebp + subl $20, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -12(%ebp) + movl -8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -12(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _put + leave + ret +.globl _primitive_dupd + .def _primitive_dupd; .scl 2; .type 32; .endef +_primitive_dupd: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_dupd_impl + leave + ret + .def _primitive_dupd_impl; .scl 3; .type 32; .endef +_primitive_dupd_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + movl -8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -8(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, (%esp) + call _dpush + leave + ret +.globl _primitive_swapd + .def _primitive_swapd; .scl 2; .type 32; .endef +_primitive_swapd: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_swapd_impl + leave + ret + .def _primitive_swapd_impl; .scl 3; .type 32; .endef +_primitive_swapd_impl: + pushl %ebp + movl %esp, %ebp + subl $16, %esp + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -4(%ebp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + movl -8(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _put + leave + ret +.globl _primitive_nip + .def _primitive_nip; .scl 2; .type 32; .endef +_primitive_nip: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_nip_impl + leave + ret + .def _primitive_nip_impl; .scl 3; .type 32; .endef +_primitive_nip_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, -4(%ebp) + movl -4(%ebp), %eax + movl %eax, (%esp) + call _drepl + leave + ret + .def _drepl; .scl 3; .type 32; .endef +_drepl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl 8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + leave + ret +.globl _primitive_2nip + .def _primitive_2nip; .scl 2; .type 32; .endef +_primitive_2nip: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_2nip_impl + leave + ret + .def _primitive_2nip_impl; .scl 3; .type 32; .endef +_primitive_2nip_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpeek + movl %eax, -4(%ebp) + subl $8, %esi + movl -4(%ebp), %eax + movl %eax, (%esp) + call _drepl + leave + ret +.globl _primitive_tuck + .def _primitive_tuck; .scl 2; .type 32; .endef +_primitive_tuck: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_tuck_impl + leave + ret + .def _primitive_tuck_impl; .scl 3; .type 32; .endef +_primitive_tuck_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + movl -8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, (%esp) + call _dpush + leave + ret +.globl _primitive_over + .def _primitive_over; .scl 2; .type 32; .endef +_primitive_over: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_over_impl + leave + ret + .def _primitive_over_impl; .scl 3; .type 32; .endef +_primitive_over_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, (%esp) + call _dpush + leave + ret +.globl _primitive_pick + .def _primitive_pick; .scl 2; .type 32; .endef +_primitive_pick: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_pick_impl + leave + ret + .def _primitive_pick_impl; .scl 3; .type 32; .endef +_primitive_pick_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + leal -8(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, (%esp) + call _dpush + leave + ret +.globl _primitive_swap + .def _primitive_swap; .scl 2; .type 32; .endef +_primitive_swap: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_swap_impl + leave + ret + .def _primitive_swap_impl; .scl 3; .type 32; .endef +_primitive_swap_impl: + pushl %ebp + movl %esp, %ebp + subl $16, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + movl -8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + leave + ret +.globl _primitive_to_r + .def _primitive_to_r; .scl 2; .type 32; .endef +_primitive_to_r: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_to_r_impl + leave + ret + .def _primitive_to_r_impl; .scl 3; .type 32; .endef +_primitive_to_r_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, (%esp) + call _rpush + leave + ret + .def _rpush; .scl 3; .type 32; .endef +_rpush: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + addl $4, %edi + movl 8(%ebp), %eax + movl %eax, 4(%esp) + movl %edi, (%esp) + call _put + leave + ret +.globl _primitive_from_r + .def _primitive_from_r; .scl 2; .type 32; .endef +_primitive_from_r: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_from_r_impl + leave + ret + .def _primitive_from_r_impl; .scl 3; .type 32; .endef +_primitive_from_r_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _rpop + movl %eax, (%esp) + call _dpush + leave + ret + .def _rpop; .scl 3; .type 32; .endef +_rpop: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %edi, (%esp) + call _get + movl %eax, -4(%ebp) + subl $4, %edi + movl -4(%ebp), %eax + leave + ret +.globl _stack_to_array + .def _stack_to_array; .scl 2; .type 32; .endef +_stack_to_array: + pushl %ebp + movl %esp, %ebp + subl $40, %esp + movl 8(%ebp), %edx + movl 12(%ebp), %eax + subl %edx, %eax + addl $4, %eax + movl %eax, -4(%ebp) + cmpl $0, -4(%ebp) + jns L58 + movl $0, -12(%ebp) + jmp L57 +L58: + movl -4(%ebp), %eax + movl %eax, -16(%ebp) + cmpl $0, -16(%ebp) + jns L60 + addl $3, -16(%ebp) +L60: + movl -16(%ebp), %eax + sarl $2, %eax + movl %eax, 4(%esp) + movl $8, (%esp) + call _allot_array_internal + movl %eax, -8(%ebp) + movl -4(%ebp), %eax + movl %eax, 8(%esp) + movl 8(%ebp), %eax + movl %eax, 4(%esp) + movl -8(%ebp), %eax + addl $8, %eax + movl %eax, (%esp) + call _memcpy + movl -8(%ebp), %eax + movl %eax, (%esp) + call _tag_object + movl %eax, (%esp) + call _dpush + movl $1, -12(%ebp) +L57: + movl -12(%ebp), %eax + leave + ret + .def _tag_object; .scl 3; .type 32; .endef +_tag_object: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + andl $-8, %eax + orl $3, %eax + popl %ebp + ret +.globl _primitive_datastack + .def _primitive_datastack; .scl 2; .type 32; .endef +_primitive_datastack: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_datastack_impl + leave + ret + .def _primitive_datastack_impl; .scl 3; .type 32; .endef +_primitive_datastack_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl %esi, 4(%esp) + movl _stack_chain, %eax + movl 24(%eax), %eax + movl (%eax), %eax + movl %eax, (%esp) + call _stack_to_array + testb %al, %al + jne L63 + movl $0, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $11, (%esp) + call _general_error +L63: + leave + ret +.globl _primitive_retainstack + .def _primitive_retainstack; .scl 2; .type 32; .endef +_primitive_retainstack: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_retainstack_impl + leave + ret + .def _primitive_retainstack_impl; .scl 3; .type 32; .endef +_primitive_retainstack_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl %edi, 4(%esp) + movl _stack_chain, %eax + movl 28(%eax), %eax + movl (%eax), %eax + movl %eax, (%esp) + call _stack_to_array + testb %al, %al + jne L66 + movl $0, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $13, (%esp) + call _general_error +L66: + leave + ret +.globl _array_to_stack + .def _array_to_stack; .scl 2; .type 32; .endef +_array_to_stack: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl 8(%ebp), %eax + movl %eax, (%esp) + call _array_capacity + sall $2, %eax + movl %eax, -4(%ebp) + movl -4(%ebp), %eax + movl %eax, 8(%esp) + movl 8(%ebp), %eax + addl $8, %eax + movl %eax, 4(%esp) + movl 12(%ebp), %eax + movl %eax, (%esp) + call _memcpy + movl -4(%ebp), %eax + addl 12(%ebp), %eax + subl $4, %eax + leave + ret + .def _array_capacity; .scl 3; .type 32; .endef +_array_capacity: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + movl 4(%eax), %eax + shrl $3, %eax + popl %ebp + ret +.globl _primitive_set_datastack + .def _primitive_set_datastack; .scl 2; .type 32; .endef +_primitive_set_datastack: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_set_datastack_impl + leave + ret + .def _primitive_set_datastack_impl; .scl 3; .type 32; .endef +_primitive_set_datastack_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, (%esp) + call _untag_array + movl %eax, %edx + movl _stack_chain, %eax + movl 24(%eax), %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl %edx, (%esp) + call _array_to_stack + movl %eax, %esi + leave + ret + .def _untag_array; .scl 3; .type 32; .endef +_untag_array: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl 8(%ebp), %eax + movl %eax, 4(%esp) + movl $8, (%esp) + call _type_check + movl 8(%ebp), %eax + movl %eax, (%esp) + call _untag_object + leave + ret + .def _untag_object; .scl 3; .type 32; .endef +_untag_object: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + andl $-8, %eax + popl %ebp + ret + .def _type_check; .scl 3; .type 32; .endef +_type_check: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl 12(%ebp), %eax + movl %eax, (%esp) + call _type_of + cmpl 8(%ebp), %eax + je L74 + movl 12(%ebp), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _type_error +L74: + leave + ret + .def _type_of; .scl 3; .type 32; .endef +_type_of: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl 8(%ebp), %eax + andl $7, %eax + movl %eax, -4(%ebp) + cmpl $3, -4(%ebp) + jne L77 + movl 8(%ebp), %eax + movl %eax, (%esp) + call _object_type + movl %eax, -8(%ebp) + jmp L76 +L77: + movl -4(%ebp), %eax + movl %eax, -8(%ebp) +L76: + movl -8(%ebp), %eax + leave + ret + .def _object_type; .scl 3; .type 32; .endef +_object_type: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl 8(%ebp), %eax + andl $-8, %eax + movl %eax, (%esp) + call _get + movl %eax, (%esp) + call _untag_header + leave + ret + .def _untag_header; .scl 3; .type 32; .endef +_untag_header: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + shrl $3, %eax + popl %ebp + ret +.globl _primitive_set_retainstack + .def _primitive_set_retainstack; .scl 2; .type 32; .endef +_primitive_set_retainstack: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_set_retainstack_impl + leave + ret + .def _primitive_set_retainstack_impl; .scl 3; .type 32; .endef +_primitive_set_retainstack_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, (%esp) + call _untag_array + movl %eax, %edx + movl _stack_chain, %eax + movl 28(%eax), %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl %edx, (%esp) + call _array_to_stack + movl %eax, %edi + leave + ret +.globl _primitive_getenv + .def _primitive_getenv; .scl 2; .type 32; .endef +_primitive_getenv: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_getenv_impl + leave + ret + .def _primitive_getenv_impl; .scl 3; .type 32; .endef +_primitive_getenv_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpeek + movl %eax, (%esp) + call _untag_fixnum_fast + movl %eax, -4(%ebp) + movl -4(%ebp), %eax + movl _userenv(,%eax,4), %eax + movl %eax, (%esp) + call _drepl + leave + ret + .def _untag_fixnum_fast; .scl 3; .type 32; .endef +_untag_fixnum_fast: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + sarl $3, %eax + popl %ebp + ret +.globl _primitive_setenv + .def _primitive_setenv; .scl 2; .type 32; .endef +_primitive_setenv: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_setenv_impl + leave + ret + .def _primitive_setenv_impl; .scl 3; .type 32; .endef +_primitive_setenv_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpop + movl %eax, (%esp) + call _untag_fixnum_fast + movl %eax, -4(%ebp) + call _dpop + movl %eax, -8(%ebp) + movl -4(%ebp), %edx + movl -8(%ebp), %eax + movl %eax, _userenv(,%edx,4) + leave + ret +.globl _primitive_exit + .def _primitive_exit; .scl 2; .type 32; .endef +_primitive_exit: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_exit_impl + leave + ret + .def _primitive_exit_impl; .scl 3; .type 32; .endef +_primitive_exit_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, (%esp) + call _to_fixnum + movl %eax, (%esp) + call _exit +.globl _primitive_os_env + .def _primitive_os_env; .scl 2; .type 32; .endef +_primitive_os_env: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_os_env_impl + leave + ret + .def _primitive_os_env_impl; .scl 3; .type 32; .endef +_primitive_os_env_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _unbox_char_string + movl %eax, -4(%ebp) + movl -4(%ebp), %eax + movl %eax, (%esp) + call _getenv + movl %eax, -8(%ebp) + cmpl $0, -8(%ebp) + jne L92 + movl $7, (%esp) + call _dpush + jmp L91 +L92: + movl -8(%ebp), %eax + movl %eax, (%esp) + call _box_char_string +L91: + leave + ret +.globl _primitive_eq + .def _primitive_eq; .scl 2; .type 32; .endef +_primitive_eq: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_eq_impl + leave + ret + .def _primitive_eq_impl; .scl 3; .type 32; .endef +_primitive_eq_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpop + movl %eax, -4(%ebp) + call _dpeek + movl %eax, -8(%ebp) + movl -4(%ebp), %eax + cmpl -8(%ebp), %eax + jne L96 + movl _T, %eax + movl %eax, -12(%ebp) + jmp L97 +L96: + movl $7, -12(%ebp) +L97: + movl -12(%ebp), %eax + movl %eax, (%esp) + call _drepl + leave + ret +.globl _primitive_millis + .def _primitive_millis; .scl 2; .type 32; .endef +_primitive_millis: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_millis_impl + leave + ret + .def _primitive_millis_impl; .scl 3; .type 32; .endef +_primitive_millis_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _current_millis + movl %eax, (%esp) + movl %edx, 4(%esp) + call _box_unsigned_8 + leave + ret +.globl _primitive_sleep + .def _primitive_sleep; .scl 2; .type 32; .endef +_primitive_sleep: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_sleep_impl + leave + ret + .def _primitive_sleep_impl; .scl 3; .type 32; .endef +_primitive_sleep_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, (%esp) + call _to_cell + movl %eax, (%esp) + call _sleep_millis + leave + ret +.globl _primitive_tag + .def _primitive_tag; .scl 2; .type 32; .endef +_primitive_tag: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_tag_impl + leave + ret + .def _primitive_tag_impl; .scl 3; .type 32; .endef +_primitive_tag_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpeek + andl $7, %eax + movl %eax, (%esp) + call _tag_fixnum + movl %eax, (%esp) + call _drepl + leave + ret + .def _tag_fixnum; .scl 3; .type 32; .endef +_tag_fixnum: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + sall $3, %eax + andl $-8, %eax + popl %ebp + ret +.globl _primitive_slot + .def _primitive_slot; .scl 2; .type 32; .endef +_primitive_slot: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_slot_impl + leave + ret + .def _primitive_slot_impl; .scl 3; .type 32; .endef +_primitive_slot_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpop + movl %eax, (%esp) + call _untag_fixnum_fast + movl %eax, -4(%ebp) + call _dpop + movl %eax, -8(%ebp) + movl -8(%ebp), %edx + andl $-8, %edx + movl -4(%ebp), %eax + sall $2, %eax + leal (%edx,%eax), %eax + movl %eax, (%esp) + call _get + movl %eax, (%esp) + call _dpush + leave + ret +.globl _primitive_set_slot + .def _primitive_set_slot; .scl 2; .type 32; .endef +_primitive_set_slot: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_set_slot_impl + leave + ret + .def _primitive_set_slot_impl; .scl 3; .type 32; .endef +_primitive_set_slot_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpop + movl %eax, (%esp) + call _untag_fixnum_fast + movl %eax, -4(%ebp) + call _dpop + movl %eax, -8(%ebp) + call _dpop + movl %eax, -12(%ebp) + movl -12(%ebp), %eax + movl %eax, 8(%esp) + movl -4(%ebp), %eax + movl %eax, 4(%esp) + movl -8(%ebp), %eax + movl %eax, (%esp) + call _set_slot + leave + ret + .def _set_slot; .scl 3; .type 32; .endef +_set_slot: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl 16(%ebp), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %edx + andl $-8, %edx + movl 12(%ebp), %eax + sall $2, %eax + leal (%edx,%eax), %eax + movl %eax, (%esp) + call _put + movl 8(%ebp), %eax + movl %eax, (%esp) + call _write_barrier + leave + ret + .def _write_barrier; .scl 3; .type 32; .endef +_write_barrier: + pushl %ebp + movl %esp, %ebp + subl $4, %esp + movl 8(%ebp), %eax + shrl $6, %eax + addl _cards_offset, %eax + movl %eax, -4(%ebp) + movl -4(%ebp), %edx + movl -4(%ebp), %eax + movzbl (%eax), %eax + orb $-64, %al + movb %al, (%edx) + leave + ret + .comm _console_open, 16 # 1 + .comm _userenv, 256 # 256 + .comm _T, 16 # 4 + .comm _stack_chain, 16 # 4 + .comm _ds_size, 16 # 4 + .comm _rs_size, 16 # 4 + .comm _stage2, 16 # 1 + .comm _profiling_p, 16 # 1 + .comm _signal_number, 16 # 4 + .comm _signal_fault_addr, 16 # 4 + .comm _signal_callstack_top, 16 # 4 + .comm _secure_gc, 16 # 1 + .comm _data_heap, 16 # 4 + .comm _cards_offset, 16 # 4 + .comm _newspace, 16 # 4 + .comm _nursery, 16 # 4 + .comm _gc_time, 16 # 8 + .comm _nursery_collections, 16 # 4 + .comm _aging_collections, 16 # 4 + .comm _cards_scanned, 16 # 4 + .comm _performing_gc, 16 # 1 + .comm _collecting_gen, 16 # 4 + .comm _collecting_aging_again, 16 # 1 + .comm _last_code_heap_scan, 16 # 4 + .comm _growing_data_heap, 16 # 1 + .comm _old_data_heap, 16 # 4 + .comm _gc_jmp, 208 # 208 + .comm _heap_scan_ptr, 16 # 4 + .comm _gc_off, 16 # 1 + .comm _gc_locals_region, 16 # 4 + .comm _gc_locals, 16 # 4 + .comm _extra_roots_region, 16 # 4 + .comm _extra_roots, 16 # 4 + .comm _bignum_zero, 16 # 4 + .comm _bignum_pos_one, 16 # 4 + .comm _bignum_neg_one, 16 # 4 + .comm _code_heap, 16 # 8 + .comm _data_relocation_base, 16 # 4 + .comm _code_relocation_base, 16 # 4 + .comm _posix_argc, 16 # 4 + .comm _posix_argv, 16 # 4 + .def _sleep_millis; .scl 3; .type 32; .endef + .def _current_millis; .scl 3; .type 32; .endef + .def _getenv; .scl 3; .type 32; .endef + .def _exit; .scl 3; .type 32; .endef + .def _general_error; .scl 3; .type 32; .endef + .def _memcpy; .scl 3; .type 32; .endef + .def _allot_array_internal; .scl 3; .type 32; .endef + .def _save_callstack_top; .scl 3; .type 32; .endef + .def _free; .scl 3; .type 32; .endef + .def _dealloc_segment; .scl 3; .type 32; .endef + .def _alloc_segment; .scl 3; .type 32; .endef + .def _safe_malloc; .scl 3; .type 32; .endef + .def _type_error; .scl 3; .type 32; .endef + .section .drectve + + .ascii " -export:nursery,data" + .ascii " -export:cards_offset,data" + .ascii " -export:stack_chain,data" + .ascii " -export:userenv,data" + .ascii " -export:unnest_stacks" + .ascii " -export:nest_stacks" + .ascii " -export:save_stacks" From fcb78822b271c72cd6f14d314e260c0624ca86ab Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 00:16:05 -0500 Subject: [PATCH 566/886] Remove annoying and useless shadowing warnings --- core/parser/parser-docs.factor | 4 ---- core/parser/parser.factor | 16 +--------------- 2 files changed, 1 insertion(+), 19 deletions(-) diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 5adecca206..d11f036445 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -284,10 +284,6 @@ HELP: use 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." } diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 7db7e46b3a..6d091fd1c0 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -191,22 +191,8 @@ 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+) ; From 457fea23f7ce862e6cebf9ffc0fa648c35b53a1b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 00:16:15 -0500 Subject: [PATCH 567/886] Improved word completion --- extra/ui/tools/listener/listener.factor | 30 +++++++++++++++---------- 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 52c3d2de42..91f7b0ec5d 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -7,7 +7,7 @@ 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 -math arrays generic accessors ; +math arrays generic accessors combinators ; IN: ui.tools.listener TUPLE: listener-gadget input output stack ; @@ -101,26 +101,32 @@ M: listener-operation invoke-command ( target command -- ) : clear-stack ( listener -- ) [ clear ] swap (call-listener) ; -GENERIC# word-completion-string 1 ( word listener -- string ) +GENERIC: word-completion-string ( word -- string ) + +M: word word-completion-string + word-name ; M: method-body word-completion-string - >r "method-generic" word-prop r> word-completion-string ; + "method-generic" word-prop word-completion-string ; USE: generic.standard.engines.tuple M: tuple-dispatch-engine-word word-completion-string - >r "engine-generic" word-prop r> word-completion-string ; + "engine-generic" word-prop word-completion-string ; -M: word word-completion-string ( word listener -- string ) - >r [ word-name ] [ word-vocabulary ] bi dup vocab-words r> - input>> interactor-use memq? - [ drop ] [ [ "USE: " % % " " % % ] "" make ] if ; +: use-if-necessary ( word seq -- ) + >r word-vocabulary vocab-words r> + { + { [ dup not ] [ 2drop ] } + { [ 2dup memq? ] [ 2drop ] } + { [ t ] [ push ] } + } cond ; : insert-word ( word -- ) - get-workspace - workspace-listener - [ word-completion-string ] keep - 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 From 368599baf81fcd864b9fd2234df882ff326a5f1a Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 7 Apr 2008 00:45:46 -0500 Subject: [PATCH 568/886] Fix to inverse, and syntax change --- extra/inverse/inverse-tests.factor | 6 ++++-- extra/inverse/inverse.factor | 17 ++++++++++------- 2 files changed, 14 insertions(+), 9 deletions(-) diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index 31e7c5f78a..101637e4e8 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -1,5 +1,5 @@ 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 @@ -51,7 +51,7 @@ C: nil { { [ ] [ list-sum + ] } { [ ] [ 0 ] } - { [ ] [ "Malformed list" throw ] } + [ "Malformed list" throw ] } switch ; [ 10 ] [ 1 2 3 4 list-sum ] unit-test @@ -59,6 +59,7 @@ C: nil [ 1 2 ] [ 1 2 [ ] undo ] unit-test [ t ] [ 1 2 [ ] matches? ] unit-test [ f ] [ 1 2 [ ] matches? ] unit-test +[ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test : empty-cons ( -- cons ) cons construct-empty ; : cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ; @@ -68,3 +69,4 @@ C: nil [ t ] [ pi [ pi ] matches? ] unit-test [ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test +[ ] [ 3 [ _ ] undo ] unit-test diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 1b7badd94a..9c94c86ce9 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -60,11 +60,13 @@ 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 ; -: enough? ( stack quot -- ? ) - [ >r length r> 1quotation infer effect-in >= ] [ 3drop f ] - recover ; +: enough? ( stack word -- ? ) + dup deferred? [ 2drop f ] [ + [ >r length r> 1quotation infer effect-in >= ] + [ 3drop f ] recover + ] if ; -: fold-word ( stack quot -- stack ) +: fold-word ( stack word -- stack ) 2dup enough? [ 1quotation with-datastack ] [ >r % r> , { } ] if ; @@ -72,10 +74,10 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; [ { } swap [ fold-word ] each % ] [ ] make ; : flattenable? ( object -- ? ) - [ [ word? ] [ primitive? not ] and? ] [ + { [ word? ] [ primitive? not ] [ { "inverse" "math-inverse" "pop-inverse" } [ word-prop ] with contains? not - ] and? ; + ] } <-&& ; : (flatten) ( quot -- ) [ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ; @@ -159,7 +161,7 @@ MACRO: undo ( quot -- ) [undo] ; 2curry ] define-pop-inverse -: _ f ; +DEFER: _ \ _ [ drop ] define-inverse : both ( object object -- object ) @@ -256,6 +258,7 @@ M: no-match summary drop "Fall through in switch" ; [ 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 ; From b0e322bffc2e59e38e4b373d1b4922b2fc933be4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 7 Apr 2008 14:19:29 -0500 Subject: [PATCH 569/886] refactor db some --- extra/db/db.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 3cade1a895..1a1a18c942 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -41,6 +41,7 @@ TUPLE: simple-statement < statement ; TUPLE: prepared-statement < statement ; TUPLE: nonthrowable-statement < statement ; TUPLE: throwable-statement < statement ; + : make-nonthrowable ( obj -- obj' ) dup sequence? [ [ make-nonthrowable ] map @@ -49,6 +50,7 @@ TUPLE: throwable-statement < statement ; ] if ; TUPLE: result-set sql in-params out-params handle n max ; + : construct-statement ( sql in out class -- statement ) construct-empty swap >>out-params @@ -101,10 +103,6 @@ M: nonthrowable-statement execute-statement ( statement -- ) swap >>in-params swap >>sql ; - ! >r >r { sql>> in-params>> out-params>> } get-slots r> - ! { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set - ! construct r> construct-delegate ; - : sql-row ( result-set -- seq ) dup #columns [ row-column ] with map ; From 4180472ae9ac1b2dc4e6aff339f5b21f389867de Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 14:45:32 -0500 Subject: [PATCH 570/886] Fix listener tests --- extra/ui/tools/listener/listener-tests.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor index 13ce834df3..cc218533d8 100755 --- a/extra/ui/tools/listener/listener-tests.factor +++ b/extra/ui/tools/listener/listener-tests.factor @@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor 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 @@ -13,11 +13,11 @@ IN: ui.tools.listener.tests "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 "i" set From a24e2786c1a87788e1533d4e33209b17aa642a71 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 7 Apr 2008 14:49:31 -0500 Subject: [PATCH 571/886] remove special case for netbsd64 gcc --- build-support/factor.sh | 5 ----- 1 file changed, 5 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index 476e885257..ea0c35aa83 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -89,11 +89,6 @@ set_md5sum() { 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 } From 719fc91432e8ec49a1c956bc8bb4bd95e7a4d63a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 7 Apr 2008 15:27:35 -0500 Subject: [PATCH 572/886] fix sqlite --- extra/db/sqlite/sqlite.factor | 4 ++-- extra/db/tuples/tuples-tests.factor | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index e0930f3ba8..11c0150cd2 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -70,7 +70,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- ) dup zero? [ "last-id failed" throw ] when ; M: sqlite-db insert-tuple* ( tuple statement -- ) - execute-statement last-insert-id >>primary-key drop ; + execute-statement last-insert-id swap set-primary-key ; M: sqlite-result-set #columns ( result-set -- n ) handle>> sqlite-#columns ; @@ -168,7 +168,7 @@ M: sqlite-db ( tuple class -- statement ) [ dup column-name>> 0% 2, ] interleave " from " 0% 0% - [ column-name>> swap get-slot-named ] with subset + [ slot-name>> swap get-slot-named ] with subset dup empty? [ drop ] [ where-clause ] if ";" 0% ] sqlite-make ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 6b61981119..951ded32ea 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -260,10 +260,10 @@ C: secret ! [ 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 + [ 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 ! \ insert-tuple must-infer ! \ update-tuple must-infer From b1b889d8994e96968a47c5f93642fc76b6eb9864 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 7 Apr 2008 15:30:06 -0500 Subject: [PATCH 573/886] add some acl constants --- extra/windows/advapi32/advapi32.factor | 195 ++++++++++++++++--------- 1 file changed, 129 insertions(+), 66 deletions(-) diff --git a/extra/windows/advapi32/advapi32.factor b/extra/windows/advapi32/advapi32.factor index 28091d3d9d..0d2f164c8d 100644 --- a/extra/windows/advapi32/advapi32.factor +++ b/extra/windows/advapi32/advapi32.factor @@ -61,6 +61,133 @@ LIBRARY: advapi32 : 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 ; @@ -85,7 +212,7 @@ LIBRARY: advapi32 ! : AddAccessDeniedAce ; ! : AddAccessDeniedAceEx ; ! : AddAccessDeniedObjectAce ; -! : AddAce ; +FUNCTION: BOOL AddAce ( PACL pAcl, DWORD dwAceRevision, DWORD dwStartingAceIndex, LPVOID pAceList, DWORD nAceListLength ) ; ! : AddAuditAccessAce ; ! : AddAuditAccessAceEx ; ! : AddAuditAccessObjectAce ; @@ -382,7 +509,7 @@ FUNCTION: BOOL GetUserNameW ( LPCTSTR lpBuffer, LPDWORD lpnSize ) ; ! : ImpersonateLoggedOnUser ; ! : ImpersonateNamedPipeClient ; ! : ImpersonateSelf ; -! : InitializeAcl ; +FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ; ! : InitializeSecurityDescriptor ; ! : InitializeSid ; ! : InitiateSystemShutdownA ; @@ -508,70 +635,6 @@ FUNCTION: BOOL LookupPrivilegeValueW ( LPCTSTR lpSystemName, ! : OpenEventLogA ; ! : OpenEventLogW ; -! typedef enum _TOKEN_INFORMATION_CLASS { -: TokenUser 1 ; -: TokenGroups 2 ; -: TokenPrivileges 3 ; -: TokenOwner 4 ; -: TokenPrimaryGroup 5 ; -: TokenDefaultDacl 6 ; -: TokenSource 7 ; -: TokenType 8 ; -: TokenImpersonationLevel 9 ; -: TokenStatistics 10 ; -: TokenRestrictedSids 11 ; -: TokenSessionId 12 ; -: TokenGroupsAndPrivileges 13 ; -: TokenSessionReference 14 ; -: TokenSandBoxInert 15 ; -! } 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 - FUNCTION: BOOL OpenProcessToken ( HANDLE ProcessHandle, DWORD DesiredAccess, PHANDLE TokenHandle ) ; From 3164cda6fb4dc8541c0154518321ca946245e54d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 15:45:08 -0500 Subject: [PATCH 574/886] Remove bogus files --- vm/data_gc.h | 4 +- vm/errors.s | 687 ----------------------- vm/run.s | 1511 -------------------------------------------------- 3 files changed, 2 insertions(+), 2200 deletions(-) delete mode 100644 vm/errors.s delete mode 100644 vm/run.s diff --git a/vm/data_gc.h b/vm/data_gc.h index 0adcf0ca39..d3b8b6e39e 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -315,8 +315,6 @@ INLINE void* allot_object(CELL type, CELL a) { CELL *object; - /* If the object is bigger than the nursery, allocate it in - tenured space */ if(nursery->size - ALLOT_BUFFER_ZONE > a) { /* If there is insufficient room, collect the nursery */ @@ -325,6 +323,8 @@ INLINE void* allot_object(CELL type, CELL a) object = allot_zone(nursery,a); } + /* If the object is bigger than the nursery, allocate it in + tenured space */ else { F_ZONE *tenured = &data_heap->generations[TENURED]; diff --git a/vm/errors.s b/vm/errors.s deleted file mode 100644 index d6b3bdb6e5..0000000000 --- a/vm/errors.s +++ /dev/null @@ -1,687 +0,0 @@ - .file "errors.c" - .section .rdata,"dr" -LC0: - .ascii "fatal_error: %s %lx\12\0" - .text -.globl _fatal_error - .def _fatal_error; .scl 2; .type 32; .endef -_fatal_error: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call ___getreent - movl %eax, %edx - movl 12(%ebp), %eax - movl %eax, 12(%esp) - movl 8(%ebp), %eax - movl %eax, 8(%esp) - movl $LC0, 4(%esp) - movl 12(%edx), %eax - movl %eax, (%esp) - call _fprintf - movl $1, (%esp) - call _exit - .section .rdata,"dr" - .align 4 -LC1: - .ascii "You have triggered a bug in Factor. Please report.\12\0" -LC2: - .ascii "critical_error: %s %lx\12\0" - .text -.globl _critical_error - .def _critical_error; .scl 2; .type 32; .endef -_critical_error: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call ___getreent - movl $LC1, 4(%esp) - movl 12(%eax), %eax - movl %eax, (%esp) - call _fprintf - call ___getreent - movl %eax, %edx - movl 12(%ebp), %eax - movl %eax, 12(%esp) - movl 8(%ebp), %eax - movl %eax, 8(%esp) - movl $LC2, 4(%esp) - movl 12(%edx), %eax - movl %eax, (%esp) - call _fprintf - call _factorbug - leave - ret - .section .rdata,"dr" -LC3: - .ascii "early_error: \0" -LC4: - .ascii "\12\0" - .text -.globl _throw_error - .def _throw_error; .scl 2; .type 32; .endef -_throw_error: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - cmpl $7, _userenv+20 - je L4 - movb $0, _gc_off - movl _gc_locals_region, %eax - movl (%eax), %eax - subl $4, %eax - movl %eax, _gc_locals - movl _extra_roots_region, %eax - movl (%eax), %eax - subl $4, %eax - movl %eax, _extra_roots - call _fix_stacks - movl 8(%ebp), %eax - movl %eax, (%esp) - call _dpush - cmpl $0, 12(%ebp) - je L5 - movl _stack_chain, %eax - movl 4(%eax), %eax - movl %eax, 4(%esp) - movl 12(%ebp), %eax - movl %eax, (%esp) - call _fix_callstack_top - movl %eax, 12(%ebp) - jmp L6 -L5: - movl _stack_chain, %eax - movl (%eax), %eax - movl %eax, 12(%ebp) -L6: - movl 12(%ebp), %edx - movl _userenv+20, %eax - call _throw_impl - jmp L3 -L4: - call ___getreent - movl $LC1, 4(%esp) - movl 12(%eax), %eax - movl %eax, (%esp) - call _fprintf - call ___getreent - movl $LC3, 4(%esp) - movl 12(%eax), %eax - movl %eax, (%esp) - call _fprintf - movl 8(%ebp), %eax - movl %eax, (%esp) - call _print_obj - call ___getreent - movl $LC4, 4(%esp) - movl 12(%eax), %eax - movl %eax, (%esp) - call _fprintf - call _factorbug -L3: - leave - ret - .def _dpush; .scl 3; .type 32; .endef -_dpush: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - addl $4, %esi - movl 8(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - leave - ret - .def _put; .scl 3; .type 32; .endef -_put: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %edx - movl 12(%ebp), %eax - movl %eax, (%edx) - popl %ebp - ret -.globl _general_error - .def _general_error; .scl 2; .type 32; .endef -_general_error: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl 8(%ebp), %eax - movl %eax, (%esp) - call _tag_fixnum - movl %eax, %edx - movl 16(%ebp), %eax - movl %eax, 12(%esp) - movl 12(%ebp), %eax - movl %eax, 8(%esp) - movl %edx, 4(%esp) - movl _userenv+24, %eax - movl %eax, (%esp) - call _allot_array_4 - movl %eax, %edx - movl 20(%ebp), %eax - movl %eax, 4(%esp) - movl %edx, (%esp) - call _throw_error - leave - ret - .def _tag_fixnum; .scl 3; .type 32; .endef -_tag_fixnum: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - sall $3, %eax - andl $-8, %eax - popl %ebp - ret -.globl _type_error - .def _type_error; .scl 2; .type 32; .endef -_type_error: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl 8(%ebp), %eax - movl %eax, (%esp) - call _tag_fixnum - movl %eax, %edx - movl $0, 12(%esp) - movl 12(%ebp), %eax - movl %eax, 8(%esp) - movl %edx, 4(%esp) - movl $3, (%esp) - call _general_error - leave - ret -.globl _not_implemented_error - .def _not_implemented_error; .scl 2; .type 32; .endef -_not_implemented_error: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl $0, 12(%esp) - movl $7, 8(%esp) - movl $7, 4(%esp) - movl $2, (%esp) - call _general_error - leave - ret -.globl _in_page - .def _in_page; .scl 2; .type 32; .endef -_in_page: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _getpagesize - movl %eax, -4(%ebp) - movl 16(%ebp), %edx - leal 12(%ebp), %eax - addl %edx, (%eax) - movl 20(%ebp), %eax - movl %eax, %edx - imull -4(%ebp), %edx - leal 12(%ebp), %eax - addl %edx, (%eax) - movb $0, -5(%ebp) - movl 8(%ebp), %eax - cmpl 12(%ebp), %eax - jb L15 - movl -4(%ebp), %eax - addl 12(%ebp), %eax - cmpl 8(%ebp), %eax - jb L15 - movb $1, -5(%ebp) -L15: - movzbl -5(%ebp), %eax - leave - ret - .section .rdata,"dr" - .align 4 -LC5: - .ascii "allot_object() missed GC check\0" -LC6: - .ascii "gc locals underflow\0" -LC7: - .ascii "gc locals overflow\0" -LC8: - .ascii "extra roots underflow\0" -LC9: - .ascii "extra roots overflow\0" - .text -.globl _memory_protection_error - .def _memory_protection_error; .scl 2; .type 32; .endef -_memory_protection_error: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl $-1, 12(%esp) - movl $0, 8(%esp) - movl _stack_chain, %eax - movl 24(%eax), %eax - movl (%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L17 - movl 12(%ebp), %eax - movl %eax, 12(%esp) - movl $7, 8(%esp) - movl $7, 4(%esp) - movl $11, (%esp) - call _general_error - jmp L16 -L17: - movl $0, 12(%esp) - movl _ds_size, %eax - movl %eax, 8(%esp) - movl _stack_chain, %eax - movl 24(%eax), %eax - movl (%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L19 - movl 12(%ebp), %eax - movl %eax, 12(%esp) - movl $7, 8(%esp) - movl $7, 4(%esp) - movl $12, (%esp) - call _general_error - jmp L16 -L19: - movl $-1, 12(%esp) - movl $0, 8(%esp) - movl _stack_chain, %eax - movl 28(%eax), %eax - movl (%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L21 - movl 12(%ebp), %eax - movl %eax, 12(%esp) - movl $7, 8(%esp) - movl $7, 4(%esp) - movl $13, (%esp) - call _general_error - jmp L16 -L21: - movl $0, 12(%esp) - movl _rs_size, %eax - movl %eax, 8(%esp) - movl _stack_chain, %eax - movl 28(%eax), %eax - movl (%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L23 - movl 12(%ebp), %eax - movl %eax, 12(%esp) - movl $7, 8(%esp) - movl $7, 4(%esp) - movl $14, (%esp) - call _general_error - jmp L16 -L23: - movl $0, 12(%esp) - movl $0, 8(%esp) - movl _nursery, %eax - movl 12(%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L25 - movl $0, 4(%esp) - movl $LC5, (%esp) - call _critical_error - jmp L16 -L25: - movl $-1, 12(%esp) - movl $0, 8(%esp) - movl _gc_locals_region, %eax - movl (%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L27 - movl $0, 4(%esp) - movl $LC6, (%esp) - call _critical_error - jmp L16 -L27: - movl $0, 12(%esp) - movl $0, 8(%esp) - movl _gc_locals_region, %eax - movl 8(%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L29 - movl $0, 4(%esp) - movl $LC7, (%esp) - call _critical_error - jmp L16 -L29: - movl $-1, 12(%esp) - movl $0, 8(%esp) - movl _extra_roots_region, %eax - movl (%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L31 - movl $0, 4(%esp) - movl $LC8, (%esp) - call _critical_error - jmp L16 -L31: - movl $0, 12(%esp) - movl $0, 8(%esp) - movl _extra_roots_region, %eax - movl 8(%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L33 - movl $0, 4(%esp) - movl $LC9, (%esp) - call _critical_error - jmp L16 -L33: - movl 8(%ebp), %eax - movl %eax, (%esp) - call _allot_cell - movl %eax, %edx - movl 12(%ebp), %eax - movl %eax, 12(%esp) - movl $7, 8(%esp) - movl %edx, 4(%esp) - movl $15, (%esp) - call _general_error -L16: - leave - ret - .def _allot_cell; .scl 3; .type 32; .endef -_allot_cell: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - cmpl $268435455, 8(%ebp) - jbe L36 - movl 8(%ebp), %eax - movl %eax, (%esp) - call _cell_to_bignum - movl %eax, (%esp) - call _tag_bignum - movl %eax, -4(%ebp) - jmp L35 -L36: - movl 8(%ebp), %eax - movl %eax, (%esp) - call _tag_fixnum - movl %eax, -4(%ebp) -L35: - movl -4(%ebp), %eax - leave - ret - .def _tag_bignum; .scl 3; .type 32; .endef -_tag_bignum: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - andl $-8, %eax - orl $1, %eax - popl %ebp - ret -.globl _signal_error - .def _signal_error; .scl 2; .type 32; .endef -_signal_error: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl 8(%ebp), %eax - movl %eax, (%esp) - call _tag_fixnum - movl %eax, %edx - movl 12(%ebp), %eax - movl %eax, 12(%esp) - movl $7, 8(%esp) - movl %edx, 4(%esp) - movl $5, (%esp) - call _general_error - leave - ret -.globl _divide_by_zero_error - .def _divide_by_zero_error; .scl 2; .type 32; .endef -_divide_by_zero_error: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl 8(%ebp), %eax - movl %eax, 12(%esp) - movl $7, 8(%esp) - movl $7, 4(%esp) - movl $4, (%esp) - call _general_error - leave - ret -.globl _memory_signal_handler_impl - .def _memory_signal_handler_impl; .scl 2; .type 32; .endef -_memory_signal_handler_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl _signal_callstack_top, %eax - movl %eax, 4(%esp) - movl _signal_fault_addr, %eax - movl %eax, (%esp) - call _memory_protection_error - leave - ret -.globl _divide_by_zero_signal_handler_impl - .def _divide_by_zero_signal_handler_impl; .scl 2; .type 32; .endef -_divide_by_zero_signal_handler_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl _signal_callstack_top, %eax - movl %eax, (%esp) - call _divide_by_zero_error - leave - ret -.globl _misc_signal_handler_impl - .def _misc_signal_handler_impl; .scl 2; .type 32; .endef -_misc_signal_handler_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl _signal_callstack_top, %eax - movl %eax, 4(%esp) - movl _signal_number, %eax - movl %eax, (%esp) - call _signal_error - leave - ret -.globl _primitive_throw - .def _primitive_throw; .scl 2; .type 32; .endef -_primitive_throw: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_throw_impl - leave - ret - .def _primitive_throw_impl; .scl 3; .type 32; .endef -_primitive_throw_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - call _dpop - movl %eax, %ecx - movl _stack_chain, %eax - movl (%eax), %edx - movl %ecx, %eax - call _throw_impl - leave - ret - .def _dpop; .scl 3; .type 32; .endef -_dpop: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %esi, (%esp) - call _get - movl %eax, -4(%ebp) - subl $4, %esi - movl -4(%ebp), %eax - leave - ret - .def _get; .scl 3; .type 32; .endef -_get: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - movl (%eax), %eax - popl %ebp - ret -.globl _primitive_call_clear - .def _primitive_call_clear; .scl 2; .type 32; .endef -_primitive_call_clear: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_call_clear_impl - leave - ret - .def _primitive_call_clear_impl; .scl 3; .type 32; .endef -_primitive_call_clear_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - movl _stack_chain, %edx - movl 4(%edx), %edx - call _throw_impl - leave - ret -.globl _primitive_unimplemented2 - .def _primitive_unimplemented2; .scl 2; .type 32; .endef -_primitive_unimplemented2: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - call _not_implemented_error - leave - ret -.globl _primitive_unimplemented - .def _primitive_unimplemented; .scl 2; .type 32; .endef -_primitive_unimplemented: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_unimplemented_impl - leave - ret - .def _primitive_unimplemented_impl; .scl 3; .type 32; .endef -_primitive_unimplemented_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _not_implemented_error - leave - ret - .comm _console_open, 16 # 1 - .comm _userenv, 256 # 256 - .comm _T, 16 # 4 - .comm _stack_chain, 16 # 4 - .comm _ds_size, 16 # 4 - .comm _rs_size, 16 # 4 - .comm _stage2, 16 # 1 - .comm _profiling_p, 16 # 1 - .comm _signal_number, 16 # 4 - .comm _signal_fault_addr, 16 # 4 - .comm _signal_callstack_top, 16 # 4 - .comm _secure_gc, 16 # 1 - .comm _data_heap, 16 # 4 - .comm _cards_offset, 16 # 4 - .comm _newspace, 16 # 4 - .comm _nursery, 16 # 4 - .comm _gc_time, 16 # 8 - .comm _nursery_collections, 16 # 4 - .comm _aging_collections, 16 # 4 - .comm _cards_scanned, 16 # 4 - .comm _performing_gc, 16 # 1 - .comm _collecting_gen, 16 # 4 - .comm _collecting_aging_again, 16 # 1 - .comm _last_code_heap_scan, 16 # 4 - .comm _growing_data_heap, 16 # 1 - .comm _old_data_heap, 16 # 4 - .comm _gc_jmp, 208 # 208 - .comm _heap_scan_ptr, 16 # 4 - .comm _gc_off, 16 # 1 - .comm _gc_locals_region, 16 # 4 - .comm _gc_locals, 16 # 4 - .comm _extra_roots_region, 16 # 4 - .comm _extra_roots, 16 # 4 - .comm _bignum_zero, 16 # 4 - .comm _bignum_pos_one, 16 # 4 - .comm _bignum_neg_one, 16 # 4 - .comm _code_heap, 16 # 8 - .comm _data_relocation_base, 16 # 4 - .comm _code_relocation_base, 16 # 4 - .comm _posix_argc, 16 # 4 - .comm _posix_argv, 16 # 4 - .def _save_callstack_top; .scl 3; .type 32; .endef - .def _getpagesize; .scl 3; .type 32; .endef - .def _allot_array_4; .scl 3; .type 32; .endef - .def _print_obj; .scl 3; .type 32; .endef - .def _throw_impl; .scl 3; .type 32; .endef - .def _fix_callstack_top; .scl 3; .type 32; .endef - .def _fix_stacks; .scl 3; .type 32; .endef - .def _factorbug; .scl 3; .type 32; .endef - .def _exit; .scl 3; .type 32; .endef - .def ___getreent; .scl 3; .type 32; .endef - .def _fprintf; .scl 3; .type 32; .endef - .def _critical_error; .scl 3; .type 32; .endef - .def _type_error; .scl 3; .type 32; .endef - .section .drectve - - .ascii " -export:nursery,data" - .ascii " -export:cards_offset,data" - .ascii " -export:stack_chain,data" - .ascii " -export:userenv,data" diff --git a/vm/run.s b/vm/run.s deleted file mode 100644 index 78b2adac84..0000000000 --- a/vm/run.s +++ /dev/null @@ -1,1511 +0,0 @@ - .file "run.c" - .text -.globl _reset_datastack - .def _reset_datastack; .scl 2; .type 32; .endef -_reset_datastack: - pushl %ebp - movl %esp, %ebp - movl _stack_chain, %eax - movl 24(%eax), %eax - movl (%eax), %esi - subl $4, %esi - popl %ebp - ret -.globl _reset_retainstack - .def _reset_retainstack; .scl 2; .type 32; .endef -_reset_retainstack: - pushl %ebp - movl %esp, %ebp - movl _stack_chain, %eax - movl 28(%eax), %eax - movl (%eax), %edi - subl $4, %edi - popl %ebp - ret -.globl _fix_stacks - .def _fix_stacks; .scl 2; .type 32; .endef -_fix_stacks: - pushl %ebp - movl %esp, %ebp - leal 4(%esi), %eax - movl _stack_chain, %edx - movl 24(%edx), %edx - cmpl (%edx), %eax - jb L5 - leal 256(%esi), %eax - movl _stack_chain, %edx - movl 24(%edx), %edx - cmpl 8(%edx), %eax - jae L5 - jmp L4 -L5: - call _reset_datastack -L4: - leal 4(%edi), %eax - movl _stack_chain, %edx - movl 28(%edx), %edx - cmpl (%edx), %eax - jb L7 - leal 256(%edi), %eax - movl _stack_chain, %edx - movl 28(%edx), %edx - cmpl 8(%edx), %eax - jae L7 - jmp L3 -L7: - call _reset_retainstack -L3: - popl %ebp - ret -.globl _save_stacks - .def _save_stacks; .scl 2; .type 32; .endef -_save_stacks: - pushl %ebp - movl %esp, %ebp - cmpl $0, _stack_chain - je L8 - movl _stack_chain, %eax - movl %esi, 8(%eax) - movl _stack_chain, %eax - movl %edi, 12(%eax) -L8: - popl %ebp - ret -.globl _nest_stacks - .def _nest_stacks; .scl 2; .type 32; .endef -_nest_stacks: - pushl %ebp - movl %esp, %ebp - pushl %ebx - subl $20, %esp - movl $44, (%esp) - call _safe_malloc - movl %eax, -8(%ebp) - movl -8(%ebp), %eax - movl $-1, 4(%eax) - movl -8(%ebp), %eax - movl $-1, (%eax) - movl -8(%ebp), %eax - movl %esi, 16(%eax) - movl -8(%ebp), %eax - movl %edi, 20(%eax) - movl -8(%ebp), %edx - movl _userenv+8, %eax - movl %eax, 36(%edx) - movl -8(%ebp), %edx - movl _userenv+4, %eax - movl %eax, 32(%edx) - movl -8(%ebp), %ebx - movl _ds_size, %eax - movl %eax, (%esp) - call _alloc_segment - movl %eax, 24(%ebx) - movl -8(%ebp), %ebx - movl _rs_size, %eax - movl %eax, (%esp) - call _alloc_segment - movl %eax, 28(%ebx) - movl -8(%ebp), %edx - movl _stack_chain, %eax - movl %eax, 40(%edx) - movl -8(%ebp), %eax - movl %eax, _stack_chain - call _reset_datastack - call _reset_retainstack - addl $20, %esp - popl %ebx - popl %ebp - ret -.globl _unnest_stacks - .def _unnest_stacks; .scl 2; .type 32; .endef -_unnest_stacks: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl _stack_chain, %eax - movl 24(%eax), %eax - movl %eax, (%esp) - call _dealloc_segment - movl _stack_chain, %eax - movl 28(%eax), %eax - movl %eax, (%esp) - call _dealloc_segment - movl _stack_chain, %eax - movl 16(%eax), %esi - movl _stack_chain, %eax - movl 20(%eax), %edi - movl _stack_chain, %eax - movl 36(%eax), %eax - movl %eax, _userenv+8 - movl _stack_chain, %eax - movl 32(%eax), %eax - movl %eax, _userenv+4 - movl _stack_chain, %eax - movl %eax, -4(%ebp) - movl -4(%ebp), %eax - movl 40(%eax), %eax - movl %eax, _stack_chain - movl -4(%ebp), %eax - movl %eax, (%esp) - call _free - leave - ret -.globl _init_stacks - .def _init_stacks; .scl 2; .type 32; .endef -_init_stacks: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - movl %eax, _ds_size - movl 12(%ebp), %eax - movl %eax, _rs_size - movl $0, _stack_chain - popl %ebp - ret -.globl _primitive_drop - .def _primitive_drop; .scl 2; .type 32; .endef -_primitive_drop: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_drop_impl - leave - ret - .def _primitive_drop_impl; .scl 3; .type 32; .endef -_primitive_drop_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - leave - ret - .def _dpop; .scl 3; .type 32; .endef -_dpop: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %esi, (%esp) - call _get - movl %eax, -4(%ebp) - subl $4, %esi - movl -4(%ebp), %eax - leave - ret - .def _get; .scl 3; .type 32; .endef -_get: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - movl (%eax), %eax - popl %ebp - ret -.globl _primitive_2drop - .def _primitive_2drop; .scl 2; .type 32; .endef -_primitive_2drop: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_2drop_impl - leave - ret - .def _primitive_2drop_impl; .scl 3; .type 32; .endef -_primitive_2drop_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esi - popl %ebp - ret -.globl _primitive_3drop - .def _primitive_3drop; .scl 2; .type 32; .endef -_primitive_3drop: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_3drop_impl - leave - ret - .def _primitive_3drop_impl; .scl 3; .type 32; .endef -_primitive_3drop_impl: - pushl %ebp - movl %esp, %ebp - subl $12, %esi - popl %ebp - ret -.globl _primitive_dup - .def _primitive_dup; .scl 2; .type 32; .endef -_primitive_dup: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_dup_impl - leave - ret - .def _primitive_dup_impl; .scl 3; .type 32; .endef -_primitive_dup_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpeek - movl %eax, (%esp) - call _dpush - leave - ret - .def _dpush; .scl 3; .type 32; .endef -_dpush: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - addl $4, %esi - movl 8(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - leave - ret - .def _put; .scl 3; .type 32; .endef -_put: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %edx - movl 12(%ebp), %eax - movl %eax, (%edx) - popl %ebp - ret - .def _dpeek; .scl 3; .type 32; .endef -_dpeek: - pushl %ebp - movl %esp, %ebp - subl $4, %esp - movl %esi, (%esp) - call _get - leave - ret -.globl _primitive_2dup - .def _primitive_2dup; .scl 2; .type 32; .endef -_primitive_2dup: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_2dup_impl - leave - ret - .def _primitive_2dup_impl; .scl 3; .type 32; .endef -_primitive_2dup_impl: - pushl %ebp - movl %esp, %ebp - subl $16, %esp - call _dpeek - movl %eax, -4(%ebp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -8(%ebp) - addl $8, %esi - movl -8(%ebp), %eax - movl %eax, 4(%esp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _put - movl -4(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - leave - ret -.globl _primitive_3dup - .def _primitive_3dup; .scl 2; .type 32; .endef -_primitive_3dup: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_3dup_impl - leave - ret - .def _primitive_3dup_impl; .scl 3; .type 32; .endef -_primitive_3dup_impl: - pushl %ebp - movl %esp, %ebp - subl $20, %esp - call _dpeek - movl %eax, -4(%ebp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -8(%ebp) - leal -8(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -12(%ebp) - addl $12, %esi - movl -4(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - movl -8(%ebp), %eax - movl %eax, 4(%esp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _put - movl -12(%ebp), %eax - movl %eax, 4(%esp) - leal -8(%esi), %eax - movl %eax, (%esp) - call _put - leave - ret -.globl _primitive_rot - .def _primitive_rot; .scl 2; .type 32; .endef -_primitive_rot: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_rot_impl - leave - ret - .def _primitive_rot_impl; .scl 3; .type 32; .endef -_primitive_rot_impl: - pushl %ebp - movl %esp, %ebp - subl $20, %esp - call _dpeek - movl %eax, -4(%ebp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -8(%ebp) - leal -8(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -12(%ebp) - movl -12(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - movl -4(%ebp), %eax - movl %eax, 4(%esp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _put - movl -8(%ebp), %eax - movl %eax, 4(%esp) - leal -8(%esi), %eax - movl %eax, (%esp) - call _put - leave - ret -.globl _primitive__rot - .def _primitive__rot; .scl 2; .type 32; .endef -_primitive__rot: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive__rot_impl - leave - ret - .def _primitive__rot_impl; .scl 3; .type 32; .endef -_primitive__rot_impl: - pushl %ebp - movl %esp, %ebp - subl $20, %esp - call _dpeek - movl %eax, -4(%ebp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -8(%ebp) - leal -8(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -12(%ebp) - movl -8(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - movl -12(%ebp), %eax - movl %eax, 4(%esp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _put - movl -4(%ebp), %eax - movl %eax, 4(%esp) - leal -8(%esi), %eax - movl %eax, (%esp) - call _put - leave - ret -.globl _primitive_dupd - .def _primitive_dupd; .scl 2; .type 32; .endef -_primitive_dupd: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_dupd_impl - leave - ret - .def _primitive_dupd_impl; .scl 3; .type 32; .endef -_primitive_dupd_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call _dpeek - movl %eax, -4(%ebp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -8(%ebp) - movl -8(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - movl -8(%ebp), %eax - movl %eax, 4(%esp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _put - movl -4(%ebp), %eax - movl %eax, (%esp) - call _dpush - leave - ret -.globl _primitive_swapd - .def _primitive_swapd; .scl 2; .type 32; .endef -_primitive_swapd: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_swapd_impl - leave - ret - .def _primitive_swapd_impl; .scl 3; .type 32; .endef -_primitive_swapd_impl: - pushl %ebp - movl %esp, %ebp - subl $16, %esp - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -4(%ebp) - leal -8(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -8(%ebp) - movl -8(%ebp), %eax - movl %eax, 4(%esp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _put - movl -4(%ebp), %eax - movl %eax, 4(%esp) - leal -8(%esi), %eax - movl %eax, (%esp) - call _put - leave - ret -.globl _primitive_nip - .def _primitive_nip; .scl 2; .type 32; .endef -_primitive_nip: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_nip_impl - leave - ret - .def _primitive_nip_impl; .scl 3; .type 32; .endef -_primitive_nip_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - movl %eax, -4(%ebp) - movl -4(%ebp), %eax - movl %eax, (%esp) - call _drepl - leave - ret - .def _drepl; .scl 3; .type 32; .endef -_drepl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl 8(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - leave - ret -.globl _primitive_2nip - .def _primitive_2nip; .scl 2; .type 32; .endef -_primitive_2nip: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_2nip_impl - leave - ret - .def _primitive_2nip_impl; .scl 3; .type 32; .endef -_primitive_2nip_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpeek - movl %eax, -4(%ebp) - subl $8, %esi - movl -4(%ebp), %eax - movl %eax, (%esp) - call _drepl - leave - ret -.globl _primitive_tuck - .def _primitive_tuck; .scl 2; .type 32; .endef -_primitive_tuck: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_tuck_impl - leave - ret - .def _primitive_tuck_impl; .scl 3; .type 32; .endef -_primitive_tuck_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call _dpeek - movl %eax, -4(%ebp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -8(%ebp) - movl -8(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - movl -4(%ebp), %eax - movl %eax, 4(%esp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _put - movl -4(%ebp), %eax - movl %eax, (%esp) - call _dpush - leave - ret -.globl _primitive_over - .def _primitive_over; .scl 2; .type 32; .endef -_primitive_over: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_over_impl - leave - ret - .def _primitive_over_impl; .scl 3; .type 32; .endef -_primitive_over_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, (%esp) - call _dpush - leave - ret -.globl _primitive_pick - .def _primitive_pick; .scl 2; .type 32; .endef -_primitive_pick: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_pick_impl - leave - ret - .def _primitive_pick_impl; .scl 3; .type 32; .endef -_primitive_pick_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - leal -8(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, (%esp) - call _dpush - leave - ret -.globl _primitive_swap - .def _primitive_swap; .scl 2; .type 32; .endef -_primitive_swap: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_swap_impl - leave - ret - .def _primitive_swap_impl; .scl 3; .type 32; .endef -_primitive_swap_impl: - pushl %ebp - movl %esp, %ebp - subl $16, %esp - call _dpeek - movl %eax, -4(%ebp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -8(%ebp) - movl -8(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - movl -4(%ebp), %eax - movl %eax, 4(%esp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _put - leave - ret -.globl _primitive_to_r - .def _primitive_to_r; .scl 2; .type 32; .endef -_primitive_to_r: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_to_r_impl - leave - ret - .def _primitive_to_r_impl; .scl 3; .type 32; .endef -_primitive_to_r_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - movl %eax, (%esp) - call _rpush - leave - ret - .def _rpush; .scl 3; .type 32; .endef -_rpush: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - addl $4, %edi - movl 8(%ebp), %eax - movl %eax, 4(%esp) - movl %edi, (%esp) - call _put - leave - ret -.globl _primitive_from_r - .def _primitive_from_r; .scl 2; .type 32; .endef -_primitive_from_r: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_from_r_impl - leave - ret - .def _primitive_from_r_impl; .scl 3; .type 32; .endef -_primitive_from_r_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _rpop - movl %eax, (%esp) - call _dpush - leave - ret - .def _rpop; .scl 3; .type 32; .endef -_rpop: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %edi, (%esp) - call _get - movl %eax, -4(%ebp) - subl $4, %edi - movl -4(%ebp), %eax - leave - ret -.globl _stack_to_array - .def _stack_to_array; .scl 2; .type 32; .endef -_stack_to_array: - pushl %ebp - movl %esp, %ebp - subl $40, %esp - movl 8(%ebp), %edx - movl 12(%ebp), %eax - subl %edx, %eax - addl $4, %eax - movl %eax, -4(%ebp) - cmpl $0, -4(%ebp) - jns L58 - movl $0, -12(%ebp) - jmp L57 -L58: - movl -4(%ebp), %eax - movl %eax, -16(%ebp) - cmpl $0, -16(%ebp) - jns L60 - addl $3, -16(%ebp) -L60: - movl -16(%ebp), %eax - sarl $2, %eax - movl %eax, 4(%esp) - movl $8, (%esp) - call _allot_array_internal - movl %eax, -8(%ebp) - movl -4(%ebp), %eax - movl %eax, 8(%esp) - movl 8(%ebp), %eax - movl %eax, 4(%esp) - movl -8(%ebp), %eax - addl $8, %eax - movl %eax, (%esp) - call _memcpy - movl -8(%ebp), %eax - movl %eax, (%esp) - call _tag_object - movl %eax, (%esp) - call _dpush - movl $1, -12(%ebp) -L57: - movl -12(%ebp), %eax - leave - ret - .def _tag_object; .scl 3; .type 32; .endef -_tag_object: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - andl $-8, %eax - orl $3, %eax - popl %ebp - ret -.globl _primitive_datastack - .def _primitive_datastack; .scl 2; .type 32; .endef -_primitive_datastack: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_datastack_impl - leave - ret - .def _primitive_datastack_impl; .scl 3; .type 32; .endef -_primitive_datastack_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl %esi, 4(%esp) - movl _stack_chain, %eax - movl 24(%eax), %eax - movl (%eax), %eax - movl %eax, (%esp) - call _stack_to_array - testb %al, %al - jne L63 - movl $0, 12(%esp) - movl $7, 8(%esp) - movl $7, 4(%esp) - movl $11, (%esp) - call _general_error -L63: - leave - ret -.globl _primitive_retainstack - .def _primitive_retainstack; .scl 2; .type 32; .endef -_primitive_retainstack: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_retainstack_impl - leave - ret - .def _primitive_retainstack_impl; .scl 3; .type 32; .endef -_primitive_retainstack_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl %edi, 4(%esp) - movl _stack_chain, %eax - movl 28(%eax), %eax - movl (%eax), %eax - movl %eax, (%esp) - call _stack_to_array - testb %al, %al - jne L66 - movl $0, 12(%esp) - movl $7, 8(%esp) - movl $7, 4(%esp) - movl $13, (%esp) - call _general_error -L66: - leave - ret -.globl _array_to_stack - .def _array_to_stack; .scl 2; .type 32; .endef -_array_to_stack: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl 8(%ebp), %eax - movl %eax, (%esp) - call _array_capacity - sall $2, %eax - movl %eax, -4(%ebp) - movl -4(%ebp), %eax - movl %eax, 8(%esp) - movl 8(%ebp), %eax - addl $8, %eax - movl %eax, 4(%esp) - movl 12(%ebp), %eax - movl %eax, (%esp) - call _memcpy - movl -4(%ebp), %eax - addl 12(%ebp), %eax - subl $4, %eax - leave - ret - .def _array_capacity; .scl 3; .type 32; .endef -_array_capacity: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - movl 4(%eax), %eax - shrl $3, %eax - popl %ebp - ret -.globl _primitive_set_datastack - .def _primitive_set_datastack; .scl 2; .type 32; .endef -_primitive_set_datastack: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_set_datastack_impl - leave - ret - .def _primitive_set_datastack_impl; .scl 3; .type 32; .endef -_primitive_set_datastack_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - movl %eax, (%esp) - call _untag_array - movl %eax, %edx - movl _stack_chain, %eax - movl 24(%eax), %eax - movl (%eax), %eax - movl %eax, 4(%esp) - movl %edx, (%esp) - call _array_to_stack - movl %eax, %esi - leave - ret - .def _untag_array; .scl 3; .type 32; .endef -_untag_array: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl 8(%ebp), %eax - movl %eax, 4(%esp) - movl $8, (%esp) - call _type_check - movl 8(%ebp), %eax - movl %eax, (%esp) - call _untag_object - leave - ret - .def _untag_object; .scl 3; .type 32; .endef -_untag_object: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - andl $-8, %eax - popl %ebp - ret - .def _type_check; .scl 3; .type 32; .endef -_type_check: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl 12(%ebp), %eax - movl %eax, (%esp) - call _type_of - cmpl 8(%ebp), %eax - je L74 - movl 12(%ebp), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _type_error -L74: - leave - ret - .def _type_of; .scl 3; .type 32; .endef -_type_of: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl 8(%ebp), %eax - andl $7, %eax - movl %eax, -4(%ebp) - cmpl $3, -4(%ebp) - jne L77 - movl 8(%ebp), %eax - movl %eax, (%esp) - call _object_type - movl %eax, -8(%ebp) - jmp L76 -L77: - movl -4(%ebp), %eax - movl %eax, -8(%ebp) -L76: - movl -8(%ebp), %eax - leave - ret - .def _object_type; .scl 3; .type 32; .endef -_object_type: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl 8(%ebp), %eax - andl $-8, %eax - movl %eax, (%esp) - call _get - movl %eax, (%esp) - call _untag_header - leave - ret - .def _untag_header; .scl 3; .type 32; .endef -_untag_header: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - shrl $3, %eax - popl %ebp - ret -.globl _primitive_set_retainstack - .def _primitive_set_retainstack; .scl 2; .type 32; .endef -_primitive_set_retainstack: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_set_retainstack_impl - leave - ret - .def _primitive_set_retainstack_impl; .scl 3; .type 32; .endef -_primitive_set_retainstack_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - movl %eax, (%esp) - call _untag_array - movl %eax, %edx - movl _stack_chain, %eax - movl 28(%eax), %eax - movl (%eax), %eax - movl %eax, 4(%esp) - movl %edx, (%esp) - call _array_to_stack - movl %eax, %edi - leave - ret -.globl _primitive_getenv - .def _primitive_getenv; .scl 2; .type 32; .endef -_primitive_getenv: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_getenv_impl - leave - ret - .def _primitive_getenv_impl; .scl 3; .type 32; .endef -_primitive_getenv_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpeek - movl %eax, (%esp) - call _untag_fixnum_fast - movl %eax, -4(%ebp) - movl -4(%ebp), %eax - movl _userenv(,%eax,4), %eax - movl %eax, (%esp) - call _drepl - leave - ret - .def _untag_fixnum_fast; .scl 3; .type 32; .endef -_untag_fixnum_fast: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - sarl $3, %eax - popl %ebp - ret -.globl _primitive_setenv - .def _primitive_setenv; .scl 2; .type 32; .endef -_primitive_setenv: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_setenv_impl - leave - ret - .def _primitive_setenv_impl; .scl 3; .type 32; .endef -_primitive_setenv_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call _dpop - movl %eax, (%esp) - call _untag_fixnum_fast - movl %eax, -4(%ebp) - call _dpop - movl %eax, -8(%ebp) - movl -4(%ebp), %edx - movl -8(%ebp), %eax - movl %eax, _userenv(,%edx,4) - leave - ret -.globl _primitive_exit - .def _primitive_exit; .scl 2; .type 32; .endef -_primitive_exit: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_exit_impl - leave - ret - .def _primitive_exit_impl; .scl 3; .type 32; .endef -_primitive_exit_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - movl %eax, (%esp) - call _to_fixnum - movl %eax, (%esp) - call _exit -.globl _primitive_os_env - .def _primitive_os_env; .scl 2; .type 32; .endef -_primitive_os_env: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_os_env_impl - leave - ret - .def _primitive_os_env_impl; .scl 3; .type 32; .endef -_primitive_os_env_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call _unbox_char_string - movl %eax, -4(%ebp) - movl -4(%ebp), %eax - movl %eax, (%esp) - call _getenv - movl %eax, -8(%ebp) - cmpl $0, -8(%ebp) - jne L92 - movl $7, (%esp) - call _dpush - jmp L91 -L92: - movl -8(%ebp), %eax - movl %eax, (%esp) - call _box_char_string -L91: - leave - ret -.globl _primitive_eq - .def _primitive_eq; .scl 2; .type 32; .endef -_primitive_eq: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_eq_impl - leave - ret - .def _primitive_eq_impl; .scl 3; .type 32; .endef -_primitive_eq_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call _dpop - movl %eax, -4(%ebp) - call _dpeek - movl %eax, -8(%ebp) - movl -4(%ebp), %eax - cmpl -8(%ebp), %eax - jne L96 - movl _T, %eax - movl %eax, -12(%ebp) - jmp L97 -L96: - movl $7, -12(%ebp) -L97: - movl -12(%ebp), %eax - movl %eax, (%esp) - call _drepl - leave - ret -.globl _primitive_millis - .def _primitive_millis; .scl 2; .type 32; .endef -_primitive_millis: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_millis_impl - leave - ret - .def _primitive_millis_impl; .scl 3; .type 32; .endef -_primitive_millis_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _current_millis - movl %eax, (%esp) - movl %edx, 4(%esp) - call _box_unsigned_8 - leave - ret -.globl _primitive_sleep - .def _primitive_sleep; .scl 2; .type 32; .endef -_primitive_sleep: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_sleep_impl - leave - ret - .def _primitive_sleep_impl; .scl 3; .type 32; .endef -_primitive_sleep_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - movl %eax, (%esp) - call _to_cell - movl %eax, (%esp) - call _sleep_millis - leave - ret -.globl _primitive_tag - .def _primitive_tag; .scl 2; .type 32; .endef -_primitive_tag: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_tag_impl - leave - ret - .def _primitive_tag_impl; .scl 3; .type 32; .endef -_primitive_tag_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpeek - andl $7, %eax - movl %eax, (%esp) - call _tag_fixnum - movl %eax, (%esp) - call _drepl - leave - ret - .def _tag_fixnum; .scl 3; .type 32; .endef -_tag_fixnum: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - sall $3, %eax - andl $-8, %eax - popl %ebp - ret -.globl _primitive_slot - .def _primitive_slot; .scl 2; .type 32; .endef -_primitive_slot: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_slot_impl - leave - ret - .def _primitive_slot_impl; .scl 3; .type 32; .endef -_primitive_slot_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call _dpop - movl %eax, (%esp) - call _untag_fixnum_fast - movl %eax, -4(%ebp) - call _dpop - movl %eax, -8(%ebp) - movl -8(%ebp), %edx - andl $-8, %edx - movl -4(%ebp), %eax - sall $2, %eax - leal (%edx,%eax), %eax - movl %eax, (%esp) - call _get - movl %eax, (%esp) - call _dpush - leave - ret -.globl _primitive_set_slot - .def _primitive_set_slot; .scl 2; .type 32; .endef -_primitive_set_slot: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_set_slot_impl - leave - ret - .def _primitive_set_slot_impl; .scl 3; .type 32; .endef -_primitive_set_slot_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call _dpop - movl %eax, (%esp) - call _untag_fixnum_fast - movl %eax, -4(%ebp) - call _dpop - movl %eax, -8(%ebp) - call _dpop - movl %eax, -12(%ebp) - movl -12(%ebp), %eax - movl %eax, 8(%esp) - movl -4(%ebp), %eax - movl %eax, 4(%esp) - movl -8(%ebp), %eax - movl %eax, (%esp) - call _set_slot - leave - ret - .def _set_slot; .scl 3; .type 32; .endef -_set_slot: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl 16(%ebp), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %edx - andl $-8, %edx - movl 12(%ebp), %eax - sall $2, %eax - leal (%edx,%eax), %eax - movl %eax, (%esp) - call _put - movl 8(%ebp), %eax - movl %eax, (%esp) - call _write_barrier - leave - ret - .def _write_barrier; .scl 3; .type 32; .endef -_write_barrier: - pushl %ebp - movl %esp, %ebp - subl $4, %esp - movl 8(%ebp), %eax - shrl $6, %eax - addl _cards_offset, %eax - movl %eax, -4(%ebp) - movl -4(%ebp), %edx - movl -4(%ebp), %eax - movzbl (%eax), %eax - orb $-64, %al - movb %al, (%edx) - leave - ret - .comm _console_open, 16 # 1 - .comm _userenv, 256 # 256 - .comm _T, 16 # 4 - .comm _stack_chain, 16 # 4 - .comm _ds_size, 16 # 4 - .comm _rs_size, 16 # 4 - .comm _stage2, 16 # 1 - .comm _profiling_p, 16 # 1 - .comm _signal_number, 16 # 4 - .comm _signal_fault_addr, 16 # 4 - .comm _signal_callstack_top, 16 # 4 - .comm _secure_gc, 16 # 1 - .comm _data_heap, 16 # 4 - .comm _cards_offset, 16 # 4 - .comm _newspace, 16 # 4 - .comm _nursery, 16 # 4 - .comm _gc_time, 16 # 8 - .comm _nursery_collections, 16 # 4 - .comm _aging_collections, 16 # 4 - .comm _cards_scanned, 16 # 4 - .comm _performing_gc, 16 # 1 - .comm _collecting_gen, 16 # 4 - .comm _collecting_aging_again, 16 # 1 - .comm _last_code_heap_scan, 16 # 4 - .comm _growing_data_heap, 16 # 1 - .comm _old_data_heap, 16 # 4 - .comm _gc_jmp, 208 # 208 - .comm _heap_scan_ptr, 16 # 4 - .comm _gc_off, 16 # 1 - .comm _gc_locals_region, 16 # 4 - .comm _gc_locals, 16 # 4 - .comm _extra_roots_region, 16 # 4 - .comm _extra_roots, 16 # 4 - .comm _bignum_zero, 16 # 4 - .comm _bignum_pos_one, 16 # 4 - .comm _bignum_neg_one, 16 # 4 - .comm _code_heap, 16 # 8 - .comm _data_relocation_base, 16 # 4 - .comm _code_relocation_base, 16 # 4 - .comm _posix_argc, 16 # 4 - .comm _posix_argv, 16 # 4 - .def _sleep_millis; .scl 3; .type 32; .endef - .def _current_millis; .scl 3; .type 32; .endef - .def _getenv; .scl 3; .type 32; .endef - .def _exit; .scl 3; .type 32; .endef - .def _general_error; .scl 3; .type 32; .endef - .def _memcpy; .scl 3; .type 32; .endef - .def _allot_array_internal; .scl 3; .type 32; .endef - .def _save_callstack_top; .scl 3; .type 32; .endef - .def _free; .scl 3; .type 32; .endef - .def _dealloc_segment; .scl 3; .type 32; .endef - .def _alloc_segment; .scl 3; .type 32; .endef - .def _safe_malloc; .scl 3; .type 32; .endef - .def _type_error; .scl 3; .type 32; .endef - .section .drectve - - .ascii " -export:nursery,data" - .ascii " -export:cards_offset,data" - .ascii " -export:stack_chain,data" - .ascii " -export:userenv,data" - .ascii " -export:unnest_stacks" - .ascii " -export:nest_stacks" - .ascii " -export:save_stacks" From 2ee0ab27d123e8af64f47c5f3688b3d358a1bb0d Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 7 Apr 2008 18:30:45 -0500 Subject: [PATCH 575/886] builder: Up bootstrap timeout to 4 hours --- extra/builder/builder.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 8e9565f82a..0e3a794e24 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -106,7 +106,7 @@ IN: builder +closed+ >>stdin "../test-log" >>stdout +stdout+ >>stderr - 120 minutes >>timeout ; + 240 minutes >>timeout ; : do-builder-test ( -- ) builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ; From 56ff4530ff9b34fcc15050fd8af66b71e751b572 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 7 Apr 2008 19:28:54 -0500 Subject: [PATCH 576/886] fix blum-blum-shub --- .../blum-blum-shub-tests.factor | 28 +++++++++++++++++++ .../blum-blum-shub/blum-blum-shub.factor | 24 ++++++---------- 2 files changed, 36 insertions(+), 16 deletions(-) create mode 100644 extra/random/blum-blum-shub/blum-blum-shub-tests.factor diff --git a/extra/random/blum-blum-shub/blum-blum-shub-tests.factor b/extra/random/blum-blum-shub/blum-blum-shub-tests.factor new file mode 100644 index 0000000000..a92f256eeb --- /dev/null +++ b/extra/random/blum-blum-shub/blum-blum-shub-tests.factor @@ -0,0 +1,28 @@ +USING: kernel math tools.test namespaces random +random.blum-blum-shub ; +IN: blum-blum-shub.tests + +[ 887708070 ] [ + T{ blum-blum-shub f 590695557939 811977232793 } random-32* +] unit-test + + +[ 887708070 ] [ + T{ blum-blum-shub f 590695557939 811977232793 } [ + 32 random-bits + ] with-random +] unit-test + +[ 5726770047455156646 ] [ + T{ blum-blum-shub f 590695557939 811977232793 } [ + 64 random-bits + ] with-random +] unit-test + +[ 3716213681 ] +[ + 100 T{ blum-blum-shub f 200352954495 846054538649 } tuck [ + random-32* drop + ] curry times + random-32* +] unit-test diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor index 017ef402c0..5644cf6d08 100755 --- a/extra/random/blum-blum-shub/blum-blum-shub.factor +++ b/extra/random/blum-blum-shub/blum-blum-shub.factor @@ -3,34 +3,26 @@ math.miller-rabin combinators.lib math.functions accessors random ; IN: random.blum-blum-shub -! TODO: take (log log M) bits instead of 1 bit -! Blum Blum Shub, M = pq +! 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 ; -C: blum-blum-shub + ( numbits -- blum-blum-shub ) - #! returns a Blum-Blum-Shub tuple generate-bbs-primes * [ find-relative-prime ] keep blum-blum-shub construct-boa ; -! 256 make-bbs blum-blum-shub set-global - : next-bbs-bit ( bbs -- bit ) - #! x = x^2 mod n, return low bit of calculated x - [ [ x>> 2 ] [ n>> ] bi ^mod ] - [ [ >>x ] keep x>> 1 bitand ] bi ; + [ [ x>> 2 ] [ n>> ] bi ^mod ] keep + over >>x drop 1 bitand ; -IN: crypto -! : random ( n -- n ) - ! ! #! Cryptographically secure random number using Blum-Blum-Shub 256 - ! [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ; +PRIVATE> M: blum-blum-shub random-32* ( bbs -- r ) - ; + 0 32 rot + [ next-bbs-bit swap 1 shift bitor ] curry times ; From f0ae86b884efe75ab55d3f6e8524a019bafd80ac Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 7 Apr 2008 19:30:02 -0500 Subject: [PATCH 577/886] remove outdated file --- extra/crypto/test/blum-blum-shub.factor | 5 ----- 1 file changed, 5 deletions(-) delete mode 100644 extra/crypto/test/blum-blum-shub.factor diff --git a/extra/crypto/test/blum-blum-shub.factor b/extra/crypto/test/blum-blum-shub.factor deleted file mode 100644 index b1b6034373..0000000000 --- a/extra/crypto/test/blum-blum-shub.factor +++ /dev/null @@ -1,5 +0,0 @@ -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 - From f7f7972756d6de6b4fab6d687092eefea214e319 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 20:07:03 -0500 Subject: [PATCH 578/886] Sequence equality on slices and reversals --- core/combinators/combinators.factor | 4 ++++ core/sequences/sequences-tests.factor | 20 +++++++++++++++++- core/sequences/sequences.factor | 30 +++++++++++++++++---------- 3 files changed, 42 insertions(+), 12 deletions(-) diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 139c6d8fdf..96c4009ba9 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -59,6 +59,10 @@ ERROR: no-case ; 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= diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 3a30824084..281b27d540 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -1,6 +1,6 @@ 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 >vector ] unit-test @@ -100,6 +100,16 @@ 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 @@ -195,6 +205,12 @@ unit-test ! Pathological case [ "ihbye" ] [ "hi" "bye" append ] unit-test +[ t ] [ "hi" SBUF" hi" = ] unit-test + +[ t ] [ "hi" SBUF" hi" = ] unit-test + +[ t ] [ "hi" SBUF" hi" [ hashcode ] bi@ = ] unit-test + [ -10 "hi" "bye" copy ] must-fail [ 10 "hi" "bye" copy ] must-fail @@ -244,3 +260,5 @@ unit-test [ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test [ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test +! Hardcore +[ ] [ "sequences" reload ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 01a1cb9b6a..996aba8e6e 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -172,7 +172,9 @@ TUPLE: reversed seq ; C: 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 @@ -198,7 +200,9 @@ ERROR: slice-error reason ; slice construct-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) ; @@ -466,6 +470,21 @@ M: sequence <=> 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 @@ -692,14 +711,3 @@ PRIVATE> dup [ length ] map infimum [ dup like ] with map ] 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 From e4f5448ae1508d979e74db1328643dbea0b7caee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 20:07:12 -0500 Subject: [PATCH 579/886] Documentation --- core/parser/parser-docs.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index d11f036445..e7984f7ec3 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -153,6 +153,8 @@ ARTICLE: "parser-files" "Parsing source files" { $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" @@ -161,6 +163,13 @@ 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 @@ -168,6 +177,7 @@ $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" } From 600740d68bfc5977ab459a3555e1f9154dac5341 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 20:07:30 -0500 Subject: [PATCH 580/886] Tweaks --- core/compiler/compiler.factor | 8 ++++---- core/optimizer/optimizer-tests.factor | 3 +++ 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index a0599f79a1..6f75ca873d 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -1,10 +1,10 @@ ! 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 -- ) diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 6c6adfa3e6..c8d7a0a0a0 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -370,4 +370,7 @@ HINTS: recursive-inline-hang-2 array ; HINTS: recursive-inline-hang-3 array ; +! Regression +USE: sequences.private +[ ] [ { (3append) } compile ] unit-test From 4c08b7dc81448fbfafdc71f33a7156d1394844ed Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 20:19:49 -0500 Subject: [PATCH 581/886] Add zip word, better code-room primitive --- core/assocs/assocs.factor | 5 ++- core/cpu/ppc/architecture/architecture.factor | 4 +-- core/generator/registers/registers.factor | 4 +-- core/inference/known-words/known-words.factor | 2 +- core/mirrors/mirrors.factor | 2 +- vm/code_gc.c | 33 ++++++++++++++----- vm/code_gc.h | 2 +- vm/code_heap.c | 9 +++++ 8 files changed, 45 insertions(+), 16 deletions(-) diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 6b6bd3d51a..adb69d317c 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -155,6 +155,9 @@ M: assoc >alist [ 2array ] { } assoc>map ; : 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 @@ -204,7 +207,7 @@ M: enum set-at seq>> set-nth ; M: enum delete-at enum-seq delete-nth ; M: enum >alist ( enum -- alist ) - seq>> [ length ] keep 2array flip ; + seq>> [ length ] keep zip ; M: enum assoc-size seq>> length ; diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index bd5273efcb..09ffead029 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -146,7 +146,7 @@ M: int-regs %save-param-reg drop 1 rot local@ STW ; M: int-regs %load-param-reg drop 1 rot local@ LWZ ; -GENERIC: STF ( src dst reg-class -- ) +GENERIC: STF ( src dst off reg-class -- ) M: single-float-regs STF drop STFS ; @@ -154,7 +154,7 @@ M: double-float-regs STF drop STFD ; M: float-regs %save-param-reg >r 1 rot local@ r> STF ; -GENERIC: LF ( src dst reg-class -- ) +GENERIC: LF ( dst src off reg-class -- ) M: single-float-regs LF drop LFS ; diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index b5b3f0b2c0..f3dc0fb10e 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -322,7 +322,7 @@ M: phantom-retainstack finalize-height : (live-locs) ( phantom -- seq ) #! Discard locs which haven't moved - [ phantom-locs* ] [ stack>> ] bi 2array flip + [ phantom-locs* ] [ stack>> ] bi zip [ live-loc? ] assoc-subset values ; @@ -421,7 +421,7 @@ M: loc lazy-store : slow-shuffle-mapping ( locs tmp -- pairs ) >r dup length r> - [ swap - ] curry map 2array flip ; + [ swap - ] curry map zip ; : slow-shuffle ( locs -- ) #! We don't have enough free registers to load all shuffle diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 8f505c21a1..33a5da87f4 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -373,7 +373,7 @@ set-primitive-effect \ data-room { } { integer array } set-primitive-effect \ data-room make-flushable -\ code-room { } { integer integer } set-primitive-effect +\ code-room { } { integer integer integer integer } set-primitive-effect \ code-room make-flushable \ os-env { string } { object } set-primitive-effect diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index a13e1331fa..61cdbdad24 100755 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -42,7 +42,7 @@ M: mirror delete-at ( key mirror -- ) M: mirror >alist ( mirror -- alist ) >mirror< [ [ slot-spec-offset slot ] with map ] keep - [ slot-spec-name ] map swap 2array flip ; + [ slot-spec-name ] map swap zip ; M: mirror assoc-size mirror-slots length ; diff --git a/vm/code_gc.c b/vm/code_gc.c index 93eb49c1be..141f4abbfe 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -198,20 +198,33 @@ void free_unmarked(F_HEAP *heap) 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 */ @@ -283,8 +296,12 @@ void recursive_mark(F_BLOCK *block) /* 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)); + dpush(tag_fixnum(used / 1024)); + dpush(tag_fixnum(total_free / 1024)); + dpush(tag_fixnum(max_free / 1024)); } /* Dump all code blocks for debugging */ diff --git a/vm/code_gc.h b/vm/code_gc.h index 32f304c16c..658dc990ae 100644 --- a/vm/code_gc.h +++ b/vm/code_gc.h @@ -32,7 +32,7 @@ void build_free_list(F_HEAP *heap, CELL size); 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) diff --git a/vm/code_heap.c b/vm/code_heap.c index ec63441bcb..92915e49d1 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -229,7 +229,16 @@ CELL allot_code_block(CELL 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; From 0f4ac3a8dc1448af61b7110b9830d3b43c2925c4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 20:44:43 -0500 Subject: [PATCH 582/886] Slot shadow warnings --- core/classes/tuple/tuple-tests.factor | 9 +++++++++ core/classes/tuple/tuple.factor | 6 +++--- core/parser/parser.factor | 29 +++++++++++++++++++-------- 3 files changed, 33 insertions(+), 11 deletions(-) diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 729997d3b2..2575570d2f 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -529,3 +529,12 @@ TUPLE: another-forget-accessors-test ; ] 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 diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 608fb8cf6c..aa8ef6cdb7 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -55,6 +55,9 @@ PRIVATE> "slot-names" word-prop [ dup array? [ second ] when ] map ; +: all-slot-names ( class -- slots ) + superclasses [ slot-names ] map concat \ class prefix ; + : define-tuple-layout ( class -- ) dup make-tuple-layout "layout" set-word-prop ; -: all-slot-names ( class -- slots ) - superclasses [ slot-names ] map concat \ class prefix ; - : compute-slot-permutation ( class old-slot-names -- permutation ) >r all-slot-names r> [ index ] curry map ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 6d091fd1c0..6c09e08f84 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -1,12 +1,11 @@ ! 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 -accessors ; +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 ; IN: parser TUPLE: lexer text line line-text line-length column ; @@ -285,13 +284,27 @@ M: no-word-error summary : CREATE-METHOD ( -- method ) scan-word bootstrap-word scan-word create-method-in ; +: shadowed-slots ( superclass slots -- shadowed ) + >r all-slot-names r> seq-intersect ; + +: check-slot-shadowing ( class superclass slots -- ) + shadowed-slots [ + [ + "Definition of slot ``" % + % + "'' in class ``" % + word-name % + "'' shadows a superclass slot" % + ] "" make note. + ] with each ; + : parse-tuple-definition ( -- class superclass slots ) CREATE-CLASS scan { { ";" [ tuple f ] } { "<" [ scan-word ";" parse-tokens ] } [ >r tuple ";" parse-tokens r> prefix ] - } case ; + } case 3dup check-slot-shadowing ; ERROR: staging-violation word ; From a48120c80b2886c56adc4b52ee092a020e78de1d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 21:04:51 -0500 Subject: [PATCH 583/886] Improve memory tooL --- extra/tools/memory/memory-tests.factor | 4 ++ extra/tools/memory/memory.factor | 58 ++++++++++++++++++-------- 2 files changed, 44 insertions(+), 18 deletions(-) diff --git a/extra/tools/memory/memory-tests.factor b/extra/tools/memory/memory-tests.factor index 9efbf63f7f..60b54c2a0d 100644 --- a/extra/tools/memory/memory-tests.factor +++ b/extra/tools/memory/memory-tests.factor @@ -1,4 +1,8 @@ USING: tools.test tools.memory ; IN: tools.memory.tests +\ room. must-infer +[ ] [ room. ] unit-test + +\ heap-stats. must-infer [ ] [ heap-stats. ] unit-test diff --git a/extra/tools/memory/memory.factor b/extra/tools/memory/memory.factor index 2077ea497e..b8fdcab280 100644 --- a/extra/tools/memory/memory.factor +++ b/extra/tools/memory/memory.factor @@ -1,22 +1,29 @@ -! 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 +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 ; @@ -25,26 +32,41 @@ IN: tools.memory [ [ write-cell ] each ] with-row ; : (data-room.) ( -- ) - data-room 2 0 [ - "Generation " pick number>string append - >r first2 r> write-total/used/free 1+ - ] reduce drop + data-room 2 dup length [ + [ first2 ] [ number>string "Generation " prepend ] bi* + write-total/used/free + ] 2each "Cards" write-total ; -: (code-room.) ( -- ) - code-room "Code space" write-total/used/free ; +: write-labelled-size ( n string -- ) + [ write-cell write-size ] with-row ; -: room. ( -- ) - standard-table-style [ - { "" "Total" "Used" "Free" } write-headings - (data-room.) - (code-room.) - ] tabular-output ; +: (code-room.) ( -- ) + 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-stats ( -- counts sizes ) H{ } clone H{ } clone [ >r 2dup r> heap-stat-step ] each-object ; From b6befe6100a692d3a24b34645d005d5a0e61e173 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 21:05:00 -0500 Subject: [PATCH 584/886] Remove redundant word --- extra/assocs/lib/lib.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index b23ee1f830..92fb9aac81 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -37,9 +37,6 @@ IN: assocs.lib : insert ( value variable -- ) namespace insert-at ; -: 2seq>assoc ( keys values exemplar -- assoc ) - >r 2array flip r> assoc-like ; - : generate-key ( assoc -- str ) >r 256 random-bits >hex r> 2dup key? [ nip generate-key ] [ drop ] if ; From 9d8062aa46f6dac5161675d7db3f4ac3fb369452 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 22:16:51 -0500 Subject: [PATCH 585/886] Remove *.lib from using --- extra/peg/peg.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index ee9037ff25..3b1d408ae2 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007, 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings fry namespaces math assocs shuffle - vectors arrays combinators.lib math.parser - unicode.categories sequences.lib compiler.units parser + vectors arrays math.parser + unicode.categories compiler.units parser words quotations effects memoize accessors locals effects splitting ; IN: peg From 8df3751049fe170114b3ced8593af74e267f1d49 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 22:32:46 -0500 Subject: [PATCH 586/886] Load fix --- extra/sequences/lib/lib.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 945ba1a3b7..2e74708aa9 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -4,7 +4,7 @@ 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 @@ -221,7 +221,7 @@ PRIVATE> [ swap nth ] with map ; : replace ( str oldseq newseq -- str' ) - H{ } 2seq>assoc substitute ; + zip >hashtable substitute ; : remove-nth ( seq n -- seq' ) cut-slice 1 tail-slice append ; From 042b5ece238cec0b67de7d441ef22c1b4ca181e7 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 8 Apr 2008 02:24:41 -0500 Subject: [PATCH 587/886] Add a few words to newfx --- extra/newfx/newfx.factor | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index df826dc295..b123fef2a3 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -1,7 +1,8 @@ -USING: kernel sequences assocs qualified ; +USING: kernel sequences assocs qualified circular ; QUALIFIED: sequences +QUALIFIED: circular IN: newfx @@ -53,8 +54,10 @@ IN: newfx ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: push ( seq obj -- seq ) over sequences:push ; -: push-on ( obj seq -- seq ) tuck sequences:push ; +: 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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -91,6 +94,10 @@ IN: newfx ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: push-circular ( seq elt -- seq ) over circular:push-circular ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! 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 From 9430478503d8fc302371c872501b9cf630356bb2 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 8 Apr 2008 02:25:14 -0500 Subject: [PATCH 588/886] sequences.lib: Add each-percent --- extra/sequences/lib/lib.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 945ba1a3b7..ac50d3f6c6 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -37,6 +37,16 @@ MACRO: firstn ( n -- ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: 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 From e67978b759bf3403e0cb6487418137f7051c7206 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 8 Apr 2008 02:26:02 -0500 Subject: [PATCH 589/886] processing: Move some items from the bubble-chamber demo --- extra/processing/processing.factor | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor index acad02363b..02a8325663 100644 --- a/extra/processing/processing.factor +++ b/extra/processing/processing.factor @@ -1,6 +1,6 @@ USING: kernel namespaces threads combinators sequences arrays - math math.functions + math math.functions math.ranges random opengl.gl opengl.glu vars multi-methods shuffle ui ui.gestures @@ -16,6 +16,18 @@ IN: processing ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: 2random ( a b -- num ) 2dup swap - 100 / random ; + +: 1random ( b -- num ) 0 swap 2random ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: chance ( fraction -- ? ) 0 1 2random > ; + +: percent-chance ( percent -- ? ) 100 / chance ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + VAR: fill-color VAR: stroke-color From 469470347b6f3692544c0ecb53c483a96708a230 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 8 Apr 2008 02:27:43 -0500 Subject: [PATCH 590/886] bubble-chamber: use inheritance for the particles --- .../bubble-chamber/bubble-chamber.factor | 92 ++++++++----------- 1 file changed, 38 insertions(+), 54 deletions(-) diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor index c6e000e74f..5d128d5102 100644 --- a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor +++ b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor @@ -25,12 +25,6 @@ IN: processing.gallery.bubble-chamber ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: 2random ( a b -- num ) 2dup swap - 100 / random ; - -: 1random ( b -- num ) 0 swap 2random ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : move-by ( obj delta -- obj ) over pos>> v+ >>pos ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -103,23 +97,34 @@ VARS: particles muons quarks hadrons axions ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +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 >>myc + 0 0 0 1 >>mya ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + GENERIC: collide ( particle -- ) GENERIC: move ( particle -- ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: muon pos speed theta speed-d theta-d theta-dd myc mya ; +TUPLE: muon < particle ; -: ( -- muon ) - muon construct-empty - 0 0 2array >>pos - 0 >>speed - 0 >>speed-d - 0 >>theta - 0 >>theta-d - 0 >>theta-dd - 0 0 0 1 >>myc - 0 0 0 1 >>mya ; +: ( -- muon ) muon construct-empty initialize-particle ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -177,18 +182,9 @@ METHOD: move { muon } ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: quark pos vel speed theta speed-d theta-d theta-dd myc ; +TUPLE: quark < particle ; -: ( -- quark ) - quark construct-empty - 0 0 2array >>pos - 0 0 2array >>vel - 0 >>speed - 0 >>speed-d - 0 >>theta - 0 >>theta-d - 0 >>theta-dd - 0 0 0 1 >>myc ; +: ( -- quark ) quark construct-empty initialize-particle ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -228,7 +224,8 @@ METHOD: move { quark } [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d [ ] [ speed>> ] [ speed-d>> ] tri * >>speed - 1000 random 997 > + ! 1000 random 997 > + 3/1000 chance [ dup speed>> neg >>speed 2 over speed-d>> - >>speed-d @@ -242,18 +239,9 @@ METHOD: move { quark } ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: hadron pos vel speed theta speed-d theta-d theta-dd myc ; +TUPLE: hadron < particle ; -: ( -- hadron ) - hadron construct-empty - 0 0 2array >>pos - 0 0 2array >>vel - 0 >>speed - 0 >>speed-d - 0 >>theta - 0 >>theta-d - 0 >>theta-dd - 0 0 0 1 >>myc ; +: ( -- hadron ) hadron construct-empty initialize-particle ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -296,12 +284,14 @@ METHOD: move { hadron } [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d [ ] [ speed>> ] [ speed-d>> ] tri * >>speed - 1000 random 997 > + ! 1000 random 997 > + 3/1000 chance [ 1.0 >>speed-d 0.00001 >>theta-dd - 100 random 70 > + ! 100 random 70 > + 30/100 chance [ dim 2 / dup 2array >>pos dup collide @@ -317,17 +307,9 @@ METHOD: move { hadron } ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: axion pos vel speed theta speed-d theta-d theta-dd ; +TUPLE: axion < particle ; -: ( -- axion ) - axion construct-empty - 0 0 2array >>pos - 0 0 2array >>vel - 0 >>speed - 0 >>speed-d - 0 >>theta - 0 >>theta-d - 0 >>theta-dd ; +: ( -- axion ) axion construct-empty initialize-particle ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -381,12 +363,14 @@ METHOD: move { axion } [ ] [ speed-d>> 0.9999 * ] bi >>speed-d - 1000 random 996 > + ! 1000 random 996 > + 4/1000 chance [ dup speed>> neg >>speed dup speed-d>> neg 2 + >>speed-d - 100 random 30 > + ! 100 random 30 > + 70/100 chance [ dim 2 / dup 2array >>pos collide From 71d1848a89c46d3e23cf23bc851cb7e3e8244cb3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 8 Apr 2008 02:28:25 -0500 Subject: [PATCH 591/886] trails: Factor out some items --- extra/processing/gallery/trails/trails.factor | 19 ++----------------- 1 file changed, 2 insertions(+), 17 deletions(-) diff --git a/extra/processing/gallery/trails/trails.factor b/extra/processing/gallery/trails/trails.factor index f0a8889fbf..dc191bc439 100644 --- a/extra/processing/gallery/trails/trails.factor +++ b/extra/processing/gallery/trails/trails.factor @@ -1,5 +1,6 @@ -USING: kernel arrays sequences math qualified circular processing ui ; +USING: kernel arrays sequences math qualified + sequences.lib circular processing ui newfx ; IN: processing.gallery.trails @@ -9,22 +10,6 @@ IN: processing.gallery.trails ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -QUALIFIED: circular - -: push-circular ( seq elt -- seq ) over circular:push-circular ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: each-percent ( seq quot -- ) - >r - dup length - dup [ / ] curry - [ 1+ ] swap compose - r> compose - 2each ; inline - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : point-list ( n -- seq ) [ drop 0 0 2array ] map ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From f71d174f38e5e1f9d4d7caac5c51917be42d6b20 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 8 Apr 2008 02:28:46 -0500 Subject: [PATCH 592/886] Add documentation for bubble-chamber --- .../bubble-chamber/bubble-chamber-docs.factor | 97 +++++++++++++++++++ 1 file changed, 97 insertions(+) create mode 100644 extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor new file mode 100644 index 0000000000..21a845e089 --- /dev/null +++ b/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor @@ -0,0 +1,97 @@ + +USING: help.syntax help.markup ; + +IN: processing.gallery.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 From e7c3d888f642e379a6af7c8741f5dfe2148e1ae3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 8 Apr 2008 04:04:12 -0500 Subject: [PATCH 593/886] math.points: Utility words for two and three dimensional points --- extra/math/points/points.factor | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 extra/math/points/points.factor diff --git a/extra/math/points/points.factor b/extra/math/points/points.factor new file mode 100644 index 0000000000..5efd6e07e0 --- /dev/null +++ b/extra/math/points/points.factor @@ -0,0 +1,22 @@ + +USING: kernel arrays math.vectors ; + +IN: math.points + + + +: 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- ; + From 94863d980de8c608902186d5b9546098c9cd6f6b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 8 Apr 2008 04:13:02 -0500 Subject: [PATCH 594/886] bubble-chamber: minor refactoring --- .../gallery/bubble-chamber/bubble-chamber.factor | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor index 5d128d5102..2efa04efad 100644 --- a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor +++ b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor @@ -7,6 +7,7 @@ USING: kernel namespaces sequences combinators arrays threads math.ranges math.constants math.functions + math.points ui ui.gadgets @@ -76,17 +77,8 @@ VARS: particles muons quarks hadrons axions ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: x>> ( particle -- x ) pos>> first ; -: y>> ( particle -- x ) pos>> second ; - -: >>x ( particle x -- particle ) over y>> 2array >>pos ; -: >>y ( particle y -- particle ) over x>> swap 2array >>pos ; - -: x x>> ; -: y y>> ; - -: v+y ( seq y -- seq ) >r first2 r> + 2array ; -: v-y ( seq y -- seq ) >r first2 r> - 2array ; +: x ( particle -- x ) pos>> first ; +: y ( particle -- x ) pos>> second ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 4cd86a06174816adefef7f3899a82cedf66be585 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Tue, 8 Apr 2008 17:32:37 -0300 Subject: [PATCH 595/886] IRC client update --- extra/irc/irc.factor | 337 ++++++++++++++++++++++++++----------------- 1 file changed, 206 insertions(+), 131 deletions(-) diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor index 8a39846fc4..0105fc53bb 100755 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -1,87 +1,130 @@ ! 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 singleton splitting strings threads + continuations classes.tuple ascii accessors ; IN: irc -! "setup" objects -TUPLE: profile server port nickname password default-channels ; -C: profile +! utils +: split-at-first ( seq separators -- before after ) + dupd '[ , member? ] find + [ cut 1 tail ] + [ swap ] + if ; -TUPLE: channel-profile name password auto-rejoin ; -C: channel-profile +: 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: irc-profile server port nickname password default-channels ; +C: irc-profile + +TUPLE: irc-channel-profile name password auto-rejoin ; +C: irc-channel-profile ! "live" objects -TUPLE: irc-client profile nick stream stream-process controller-process ; -C: irc-client - TUPLE: nick name channels log ; C: nick -TUPLE: channel name topic members log attributes ; -C: channel +TUPLE: irc-client profile nick stream stream-channel controller-channel + listeners is-running ; +: ( profile -- irc-client ) + f V{ } clone V{ } clone + f V{ } clone f irc-client construct-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?? +: ( quot -- irc-listener ) + irc-listener construct-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 ! the delegate of all irc messages -TUPLE: irc-message timestamp ; +TUPLE: irc-message line prefix command parameters trailing timestamp ; C: irc-message ! "irc message" objects -TUPLE: logged-in name text ; +TUPLE: logged-in < irc-message name ; C: logged-in -TUPLE: ping name ; +TUPLE: ping < irc-message ; C: ping -TUPLE: join name channel ; -C: join +TUPLE: join_ < irc-message ; +C: join_ -TUPLE: part name channel text ; +TUPLE: part < irc-message name channel ; C: part -TUPLE: quit text ; +TUPLE: quit ; C: quit -TUPLE: privmsg name text ; +TUPLE: privmsg < irc-message name ; C: privmsg -TUPLE: kick channel er ee text ; +TUPLE: kick < irc-message channel who ; C: kick -TUPLE: roomlist channel names ; +TUPLE: roomlist < irc-message channel names ; C: roomlist -TUPLE: nick-in-use name ; +TUPLE: nick-in-use < irc-message name ; C: nick-in-use -TUPLE: notice type text ; +TUPLE: notice < irc-message type ; C: notice -TUPLE: mode name channel mode text ; +TUPLE: mode < irc-message name channel mode ; C: mode -! TUPLE: members -TUPLE: unhandled text ; +TUPLE: unhandled < irc-message ; C: 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 ; + : me? ( name -- ? ) - irc-client get irc-client-nick nick-name = ; + irc-client> nick>> name>> = ; : irc-write ( s -- ) irc-stream> stream-write ; @@ -89,123 +132,155 @@ SYMBOL: irc-client : 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 -- ) - utf8 irc-client get set-irc-client-stream ; +: CONNECT ( server port -- stream ) + latin1 ; -: connect ( server -- ) 6667 connect* ; - -: 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 ; -: quit ( text -- ) +: SAY ( nick line -- ) + PRIVMSG ; + +: 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 ; + name>> "_" append NICK ; -: delegate-timestamp ( obj -- obj ) - now over set-delegate ; +: 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 add* >tuple ; -MATCH-VARS: ?name ?name2 ?channel ?text ?mode ; -SYMBOL: line -: match-irc ( string -- ) - dup line set - dup print flush - irc-split - { - { { "PING" ?name } - [ ?name ] } - { { ?name "001" ?name2 ?text } - [ ?name2 ?text ] } - { { ?name "433" _ ?name2 "Nickname is already in use." } - [ ?name2 ] } +! Reader +: handle-reader-message ( irc-client irc-message -- ) + dup handle-irc swap stream-channel>> to ; - { { ?name "JOIN" ?channel } - [ ?name ?channel ] } - { { ?name "PART" ?channel ?text } - [ ?name ?channel ?text ] } - { { ?name "PRIVMSG" ?channel ?text } - [ ?name ?channel ?text ] } - { { ?name "QUIT" ?text } - [ ?name ?text ] } +: 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* ; - { { "NOTICE" ?name ?text } - [ ?name ?text ] } - { { ?name "MODE" ?channel ?mode ?text } - [ ?name ?channel ?mode ?text ] } - { { ?name "KICK" ?channel ?name2 ?text } - [ ?channel ?name ?name2 ?text ] } +! Controller commands +GENERIC: handle-command ( obj -- ) - ! { { ?name "353" ?name2 _ ?channel ?text } - ! [ ?text ?channel ?name2 make-member-list ] } - { _ [ line get ] } - } match-cond - delegate-timestamp handle-irc flush ; +M: object handle-command ( obj -- ) + . ; -: irc-loop ( -- ) - irc-stream> stream-readln - [ match-irc irc-loop ] when* ; +TUPLE: send-message to text ; +C: send-message +M: send-message handle-command ( obj -- ) + dup to>> swap text>> SAY ; +TUPLE: send-action to text ; +C: send-action +M: send-action handle-command ( obj -- ) + dup to>> swap text>> ACTION ; + +TUPLE: send-quit text ; +C: send-quit +M: send-quit handle-command ( obj -- ) + text>> QUIT ; + +: irc-listen ( irc-client quot -- ) + [ listeners>> ] [ ] 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 , - ] { } make - f V{ } clone V{ } clone - f f f ; - -: 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 From 2cebf7e9e59790ba5a9531e33b4c6509f35f9c4d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Apr 2008 18:51:56 -0500 Subject: [PATCH 596/886] Improve multi-methods: multi-var hooks --- .../multi-methods/multi-methods-tests.factor | 98 ------ extra/multi-methods/multi-methods.factor | 309 ++++++++++-------- extra/multi-methods/tests/canonicalize.factor | 66 ++++ extra/multi-methods/tests/definitions.factor | 37 +++ extra/multi-methods/tests/legacy.factor | 10 + extra/multi-methods/tests/syntax.factor | 58 ++++ .../tests/topological-sort.factor | 18 + 7 files changed, 357 insertions(+), 239 deletions(-) delete mode 100755 extra/multi-methods/multi-methods-tests.factor create mode 100644 extra/multi-methods/tests/canonicalize.factor create mode 100644 extra/multi-methods/tests/definitions.factor create mode 100644 extra/multi-methods/tests/legacy.factor create mode 100644 extra/multi-methods/tests/syntax.factor create mode 100644 extra/multi-methods/tests/topological-sort.factor diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor deleted file mode 100755 index 8910e64092..0000000000 --- a/extra/multi-methods/multi-methods-tests.factor +++ /dev/null @@ -1,98 +0,0 @@ -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 } ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 115432b14d..0276e1422c 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -3,13 +3,74 @@ 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 [ 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 dup 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 >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? @@ -32,6 +93,10 @@ GENERIC: method-prologue ( combination -- quot ) } 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 ] ] } @@ -52,209 +117,171 @@ GENERIC: method-prologue ( combination -- quot ) unclip [ swap [ f ] \ if 3array append [ ] like ] reduce ] if ; +: multi-dispatch-quot ( methods generic -- quot ) + "default-multi-method" word-prop 1quotation swap + [ >r multi-predicate r> ] assoc-map reverse 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 ; +! Methods PREDICATE: method-body < word - "multi-method" word-prop >boolean ; + "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 ; M: method-body crossref? drop t ; -: method-word-name ( classes generic -- string ) +: method-word-name ( specializer generic -- string ) + [ word-name % "-" % unparse % ] "" make ; + +: method-word-props ( specializer generic -- assoc ) [ - word-name % - "-(" % [ "," % ] [ word-name % ] interleave ")" % - ] "" make ; + "multi-method-generic" set + "multi-method-specializer" set + ] H{ } make-assoc ; -: ( 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 +: ( specializer generic -- word ) + [ method-word-props ] 2keep method-word-name f - dup rot define - dup xref ; + [ set-word-props ] keep ; -: ( quot classes generic -- method ) - [ ] 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 + +: reveal-method ( method classes generic -- ) + [ set-at ] with-methods ; + +: method ( classes word -- method ) + "multi-methods" word-prop at ; + +: create-method ( classes generic -- method ) + 2dup method dup [ + 2nip + ] [ + drop [ dup ] 2keep reveal-method + ] if ; TUPLE: no-method arguments generic ; : no-method ( argument-count generic -- * ) >r narray r> \ no-method construct-boa throw ; inline -: argument-count ( methods -- n ) - dup assoc-empty? [ drop 0 ] [ - keys [ length ] map supremum - ] 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 ] bi@ 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 + "Available methods: " print + generic>> methods keys [ niceify-method ] map stack. ; -TUPLE: standard-combination ; +: make-default-method ( generic -- quot ) + [ 0 swap no-method ] curry ; -M: standard-combination method-prologue drop [ ] ; +: ( generic -- method ) + [ { } swap ] keep + [ drop ] [ make-default-method define ] 2bi ; -M: standard-combination generic-prologue drop [ ] ; +: define-default-method ( generic -- ) + dup "default-multi-method" set-word-prop ; -: 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 ; - -: update-generic ( word -- ) - dup make-generic define ; - -: define-generic ( word combination -- ) - over "multi-combination" word-prop over = [ - 2drop - ] [ - dupd "multi-combination" set-word-prop - dup H{ } clone "multi-methods" set-word-prop - update-generic - ] if ; - -: define-standard-generic ( word -- ) - T{ standard-combination } define-generic ; - -: 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 - -: define-method ( quot classes generic -- ) - >r [ bootstrap-word ] map r> - [ ] 2keep - [ set-at ] with-methods ; - -: forget-method ( classes generic -- ) +: forget-method ( specializer generic -- ) [ delete-at ] with-methods ; : method>spec ( method -- spec ) - dup method-classes swap method-generic prefix ; + [ "multi-method-specializer" word-prop ] + [ "multi-method-generic" word-prop ] bi prefix ; + +: define-generic ( word -- ) + dup "multi-methods" word-prop [ + drop + ] [ + [ H{ } clone "multi-methods" set-word-prop ] + [ define-default-method ] + [ update-generic ] + tri + ] if ; + +! Syntax +: GENERIC: + CREATE define-generic ; parsing : parse-method ( -- quot classes generic ) - parse-definition dup 2 tail over second rot first ; + parse-definition [ 2 tail ] [ second ] [ first ] tri ; -: METHOD: - location - >r parse-method [ define-method ] 2keep prefix r> - remember-definition ; parsing +: create-method-in ( specializer generic -- method ) + create-method dup save-location f set-word ; + +: CREATE-METHOD + scan-word scan-object swap create-method-in ; + +: (METHOD:) CREATE-METHOD parse-definition ; + +: 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: generic < word - "multi-combination" word-prop >boolean ; +syntax:M: generic definer drop \ GENERIC: f ; -PREDICATE: standard-generic < word - "multi-combination" word-prop standard-combination? ; - -PREDICATE: hook-generic < word - "multi-combination" word-prop hook-combination? ; - -syntax:M: standard-generic definer drop \ GENERIC: f ; - -syntax:M: standard-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. ; +syntax:M: generic definition drop f ; 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 ; diff --git a/extra/multi-methods/tests/canonicalize.factor b/extra/multi-methods/tests/canonicalize.factor new file mode 100644 index 0000000000..d5baf4914c --- /dev/null +++ b/extra/multi-methods/tests/canonicalize.factor @@ -0,0 +1,66 @@ +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 diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor new file mode 100644 index 0000000000..60ddd32875 --- /dev/null +++ b/extra/multi-methods/tests/definitions.factor @@ -0,0 +1,37 @@ +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 +\ define-default-method 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-body? ] unit-test + +[ + [ ] [ \ fake define-default-method ] unit-test + + [ { } [ ] ] [ \ fake methods prepare-methods >r sort-methods r> ] unit-test + + [ t ] [ { } \ fake multi-dispatch-quot quotation? ] 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 + + [ t ] [ \ testing "default-multi-method" word-prop method-body? ] unit-test +] with-compilation-unit diff --git a/extra/multi-methods/tests/legacy.factor b/extra/multi-methods/tests/legacy.factor new file mode 100644 index 0000000000..f4bd0a00b2 --- /dev/null +++ b/extra/multi-methods/tests/legacy.factor @@ -0,0 +1,10 @@ +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 diff --git a/extra/multi-methods/tests/syntax.factor b/extra/multi-methods/tests/syntax.factor new file mode 100644 index 0000000000..5e2e86d04b --- /dev/null +++ b/extra/multi-methods/tests/syntax.factor @@ -0,0 +1,58 @@ +IN: multi-methods.tests +USING: multi-methods tools.test math sequences namespaces system +kernel strings definitions prettyprint debugger arrays +hashtables continuations classes assocs ; + +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 +[ 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 + +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 } ; diff --git a/extra/multi-methods/tests/topological-sort.factor b/extra/multi-methods/tests/topological-sort.factor new file mode 100644 index 0000000000..ed8bece4ba --- /dev/null +++ b/extra/multi-methods/tests/topological-sort.factor @@ -0,0 +1,18 @@ +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 From a82794a71910cfaea3471a95db65e8d101a95557 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Apr 2008 19:12:48 -0500 Subject: [PATCH 597/886] Fixing error reporting --- extra/multi-methods/multi-methods.factor | 35 ++++++++------------ extra/multi-methods/tests/definitions.factor | 5 +-- extra/multi-methods/tests/syntax.factor | 8 ++++- 3 files changed, 22 insertions(+), 26 deletions(-) diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 0276e1422c..8f9e34b1fb 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -117,9 +117,18 @@ SYMBOL: total 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 ) - "default-multi-method" word-prop 1quotation swap - [ >r multi-predicate r> ] assoc-map reverse alist>quot ; + [ make-default-method ] + [ drop [ >r multi-predicate r> ] assoc-map reverse ] + 2bi alist>quot ; ! Generic words PREDICATE: generic < word @@ -178,11 +187,6 @@ M: method-body crossref? drop [ dup ] 2keep reveal-method ] if ; -TUPLE: no-method arguments generic ; - -: no-method ( argument-count generic -- * ) - >r narray r> \ no-method construct-boa throw ; inline - : niceify-method [ dup \ f eq? [ drop f ] when ] map ; M: no-method error. @@ -196,18 +200,8 @@ M: no-method error. dup arguments>> [ class ] map niceify-method . nl "Available methods: " print - generic>> methods keys - [ niceify-method ] map stack. ; - -: make-default-method ( generic -- quot ) - [ 0 swap no-method ] curry ; - -: ( generic -- method ) - [ { } swap ] keep - [ drop ] [ make-default-method define ] 2bi ; - -: define-default-method ( generic -- ) - dup "default-multi-method" set-word-prop ; + generic>> methods canonicalize-specializers drop sort-methods + keys [ niceify-method ] map stack. ; : forget-method ( specializer generic -- ) [ delete-at ] with-methods ; @@ -221,9 +215,8 @@ M: no-method error. drop ] [ [ H{ } clone "multi-methods" set-word-prop ] - [ define-default-method ] [ update-generic ] - tri + bi ] if ; ! Syntax diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor index 60ddd32875..fea8f0c402 100644 --- a/extra/multi-methods/tests/definitions.factor +++ b/extra/multi-methods/tests/definitions.factor @@ -4,7 +4,6 @@ kernel strings words compiler.units quotations ; \ GENERIC: must-infer \ create-method-in must-infer -\ define-default-method must-infer DEFER: fake \ fake H{ } clone "multi-methods" set-word-prop @@ -17,11 +16,9 @@ DEFER: fake [ t ] [ { } \ fake method-body? ] unit-test [ - [ ] [ \ fake define-default-method ] unit-test - [ { } [ ] ] [ \ fake methods prepare-methods >r sort-methods r> ] unit-test - [ t ] [ { } \ fake multi-dispatch-quot quotation? ] unit-test + [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test [ t ] [ \ fake make-generic quotation? ] unit-test diff --git a/extra/multi-methods/tests/syntax.factor b/extra/multi-methods/tests/syntax.factor index 5e2e86d04b..597a1cebeb 100644 --- a/extra/multi-methods/tests/syntax.factor +++ b/extra/multi-methods/tests/syntax.factor @@ -1,7 +1,7 @@ IN: multi-methods.tests USING: multi-methods tools.test math sequences namespaces system kernel strings definitions prettyprint debugger arrays -hashtables continuations classes assocs ; +hashtables continuations classes assocs accessors ; GENERIC: first-test @@ -25,6 +25,7 @@ METHOD: beats? { thing thing } f ; [ { } 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 @@ -45,6 +46,11 @@ METHOD: hook-test { hashtable { some-var number } } assoc-size ; 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 ; From 9c19ade9810857c98cf41228f59982736ef53d5b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Apr 2008 19:43:54 -0500 Subject: [PATCH 598/886] Fix library path --- extra/db/postgresql/ffi/ffi.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index 7f428bb6b6..ee5ba622e5 100755 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -6,8 +6,7 @@ IN: db.postgresql.ffi << "postgresql" { { [ os winnt? ] [ "libpq.dll" ] } - { [ os macosx? ] [ "/opt/local/lib/postgresql83/libpq.dylib" ] } - ! { [ os macosx? ] [ "libpq.dylib" ] } + { [ os macosx? ] [ "libpq.dylib" ] } { [ os unix? ] [ "libpq.so" ] } } cond "cdecl" add-library >> From 0dd8e462c6dc31065dcdee6d33913edd3a3688e5 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 9 Apr 2008 12:52:49 +1200 Subject: [PATCH 599/886] Minor peg refactorings --- extra/peg/peg.factor | 75 +++++++++++++++++++++++--------------------- 1 file changed, 40 insertions(+), 35 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 3b1d408ae2..7390c15684 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -30,6 +30,9 @@ SYMBOL: fail SYMBOL: lrstack SYMBOL: heads +: failed? ( obj -- ? ) + fail = ; + : delegates ( -- cache ) \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ; @@ -66,21 +69,18 @@ C: peg-head #! that maps the position to the parser result. id>> packrat get [ drop H{ } clone ] cache ; +: process-rule-result ( p result -- result ) + [ + nip [ ast>> ] [ remaining>> ] bi input-from pos set + ] [ + 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 -! drop f f - [ - nip - [ ast>> ] [ remaining>> ] bi - input-from pos set - ] [ - pos set - fail - ] if* ; inline + pos get swap execute process-rule-result ; inline : memo ( pos rule -- memo-entry ) #! Return the result from the memo cache. @@ -90,21 +90,29 @@ C: peg-head #! Store an entry in the cache rule-parser input-cache set-at ; -:: (grow-lr) ( r p m h -- ) - p pos set - h involved-set>> clone h (>>eval-set) +: 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 -- ) + h p setup-growth r eval-rule - dup fail = pos get m pos>> <= or [ + dup m stop-growth? [ drop ] [ - m (>>ans) - pos get m (>>pos) - r p m h (grow-lr) + m update-m + h p r m (grow-lr) ] if ; inline -:: grow-lr ( r p m h -- ast ) +:: grow-lr ( h p r m -- ast ) h p heads get set-at - r p m h (grow-lr) + h p r m (grow-lr) p heads get delete-at m pos>> pos set m ans>> ; inline @@ -128,10 +136,10 @@ C: peg-head | h rule>> r eq? [ m ans>> seed>> m (>>ans) - m ans>> fail = [ + m ans>> failed? [ fail ] [ - r p m h grow-lr + h p r m grow-lr ] if ] [ m ans>> seed>> @@ -150,8 +158,7 @@ C: peg-head r h eval-set>> member? [ h [ r swap remove ] change-eval-set drop r eval-rule - m (>>ans) - pos get m (>>pos) + m update-m m ] [ m @@ -207,20 +214,18 @@ C: peg-head GENERIC: (compile) ( parser -- quot ) +: execute-parser ( word -- result ) + pos get apply-rule dup failed? [ + drop f + ] [ + input-slice swap + ] if ; inline -:: parser-body ( parser -- quot ) +: parser-body ( parser -- quot ) #! Return the body of the word that is the compiled version #! of the parser. - [let* | rule [ gensym dup parser (compile) 0 1 define-declared dup parser "peg" set-word-prop ] - | - [ - rule pos get apply-rule dup fail = [ - drop f - ] [ - input-slice swap - ] if - ] - ] ; + gensym 2dup swap (compile) 0 1 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. From 411a13756395cbf142d7212868cc8512eff50aff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Apr 2008 21:29:37 -0500 Subject: [PATCH 600/886] Fix unit test --- extra/multi-methods/tests/definitions.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor index fea8f0c402..c112a67776 100644 --- a/extra/multi-methods/tests/definitions.factor +++ b/extra/multi-methods/tests/definitions.factor @@ -29,6 +29,4 @@ DEFER: fake [ ] [ \ testing define-generic ] unit-test [ t ] [ \ testing generic? ] unit-test - - [ t ] [ \ testing "default-multi-method" word-prop method-body? ] unit-test ] with-compilation-unit From 6c5935a3b0e604afa7606384f66183bbfc87e577 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 8 Apr 2008 23:08:11 -0500 Subject: [PATCH 601/886] add set-os-env, unset-os-env --- core/bootstrap/primitives.factor | 2 ++ core/inference/known-words/known-words.factor | 4 ++++ vm/os-unix.c | 15 +++++++++++++++ vm/primitives.c | 2 ++ vm/run.h | 2 ++ 5 files changed, 25 insertions(+) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 233de6f4ee..9d3c28b068 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -732,6 +732,8 @@ define-builtin { "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" } diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 33a5da87f4..453e2460b0 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -587,6 +587,10 @@ set-primitive-effect \ (os-envs) { } { array } set-primitive-effect +\ set-os-env { string string } { } set-primitive-effect + +\ unset-os-env { string } { } set-primitive-effect + \ (set-os-envs) { array } { } set-primitive-effect \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop diff --git a/vm/os-unix.c b/vm/os-unix.c index 74320288aa..2991cde78c 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -103,6 +103,21 @@ DEFINE_PRIMITIVE(os_envs) 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()); diff --git a/vm/primitives.c b/vm/primitives.c index 533fcebc9a..2906a154a2 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -182,6 +182,8 @@ void *primitives[] = { 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, diff --git a/vm/run.h b/vm/run.h index c112c5f587..e2afb08525 100755 --- a/vm/run.h +++ b/vm/run.h @@ -249,6 +249,8 @@ DECLARE_PRIMITIVE(setenv); 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); From c19505cd844e9fb14fffadf937bdfee7d52089b4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 8 Apr 2008 23:35:28 -0500 Subject: [PATCH 602/886] set-os-env on windows --- vm/os-windows.c | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/vm/os-windows.c b/vm/os-windows.c index 664df9e774..b3fc1c917f 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -215,6 +215,21 @@ void sleep_millis(DWORD msec) Sleep(msec); } +DEFINE_PRIMITIVE(set_os_env) +{ + char *key = unbox_char_string(); + REGISTER_C_STRING(key); + char *value = unbox_char_string(); + UNREGISTER_C_STRING(key); + SetEnvironmentVariable(key, value); +} + +DEFINE_PRIMITIVE(unset_os_env) +{ + char *key = unbox_char_string(); + SetEnvironmentVariable(key, f); +} + DEFINE_PRIMITIVE(set_os_envs) { not_implemented_error(); From 52bb93cf40a878577ce33ebd8f9766ffeab102cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 00:19:56 -0500 Subject: [PATCH 603/886] Working on faster refresh-all --- extra/tools/vocabs/monitor/monitor.factor | 39 +++++++++++----- extra/tools/vocabs/vocabs.factor | 57 ++++++++++++----------- 2 files changed, 56 insertions(+), 40 deletions(-) diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index 071f179676..ada539c60a 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -1,24 +1,39 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: threads io.files io.monitors init kernel -vocabs.loader tools.vocabs namespaces continuations ; +vocabs vocabs.loader tools.vocabs namespaces continuations +sequences splitting assocs ; IN: tools.vocabs.monitor -! Use file system change monitoring to flush the tags/authors -! cache -SYMBOL: vocab-monitor +: vocab-dir>vocab-name ( path -- vocab ) + left-trim-separators right-trim-separators + { { CHAR: / CHAR: . } { CHAR: \\ CHAR: . } } substitute ; -: monitor-thread ( -- ) - vocab-monitor get-global - next-change 2drop - t sources-changed? set-global reset-cache ; +: path>vocab-name ( path -- vocab ) + dup ".factor" tail? [ parent-directory ] when + dup [ vocab-dir>vocab-name ] when ; -: start-monitor-thread +: changed-vocab ( vocab -- ) + dup vocab + [ dup changed-vocabs get-global set-at ] [ drop ] if ; + +: monitor-thread ( path monitor -- ) + #! On OS X, monitors give us the full path, so we chop it + #! off if its there. + next-change drop swap ?head drop + path>vocab-name changed-vocab reset-cache ; + +: start-monitor-thread ( root -- ) #! Silently ignore errors during monitor creation since #! monitors are not supported on all platforms. + (normalize-path) dup t [ monitor-thread t ] 2curry + "Vocabulary monitor" spawn-server drop ; + +: start-monitor-threads ( -- ) [ - "" resource-path t vocab-monitor set-global - [ monitor-thread t ] "Vocabulary monitor" spawn-server drop + vocab-roots get [ start-monitor-thread ] each + H{ } clone changed-vocabs set-global + vocabs [ changed-vocab ] each ] ignore-errors ; -[ start-monitor-thread ] "tools.vocabs.monitor" add-init-hook +[ start-monitor-threads ] "tools.vocabs.monitor" add-init-hook diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 2f941ad2ce..825d2a6329 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -21,15 +21,15 @@ IN: tools.vocabs : vocab-tests ( vocab -- tests ) [ - dup vocab-tests-file [ , ] when* - vocab-tests-dir [ % ] when* + [ vocab-tests-file [ , ] when* ] + [ vocab-tests-dir [ % ] when* ] bi ] { } make ; : vocab-files ( vocab -- seq ) [ - dup vocab-source-path [ , ] when* - dup vocab-docs-path [ , ] when* - vocab-tests % + [ vocab-source-path [ , ] when* ] + [ vocab-docs-path [ , ] when* ] + [ vocab-tests % ] tri ] { } make ; : source-modified? ( path -- ? ) @@ -56,20 +56,27 @@ IN: tools.vocabs : modified-docs ( vocabs -- seq ) [ vocab-docs-path ] modified ; +SYMBOL: changed-vocabs + +[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook + +: filter-changed ( vocabs -- vocabs' ) + changed-vocabs get [ + [ delete-at* nip ] curry subset + ] when* ; + : to-refresh ( prefix -- modified-sources modified-docs ) - child-vocabs - dup modified-sources swap modified-docs ; + child-vocabs filter-changed + [ modified-sources ] [ modified-docs ] bi ; : vocab-heading. ( vocab -- ) nl "==== " write - dup vocab-name swap vocab write-object ":" print + [ vocab-name ] [ vocab write-object ] bi ":" print nl ; : load-error. ( triple -- ) - dup first vocab-heading. - dup second print-error - drop ; + [ first vocab-heading. ] [ second print-error ] bi ; : load-failures. ( failures -- ) [ load-error. nl ] each ; @@ -89,30 +96,24 @@ SYMBOL: failures ] with-compiler-errors ; : do-refresh ( modified-sources modified-docs -- ) - 2dup - [ f swap set-vocab-docs-loaded? ] each - [ f swap set-vocab-source-loaded? ] each - append prune require-all load-failures. ; + [ + [ [ f swap set-vocab-source-loaded? ] each ] + [ [ f swap set-vocab-docs-loaded? ] each ] bi* + ] + [ append prune require-all load-failures. ] 2bi ; : refresh ( prefix -- ) to-refresh do-refresh ; -SYMBOL: sources-changed? +: refresh-all ( -- ) "" refresh ; -[ t sources-changed? set-global ] "tools.vocabs" add-init-hook - -: refresh-all ( -- ) - "" refresh f sources-changed? set-global ; - -MEMO: (vocab-file-contents) ( path -- lines ) - dup exists? [ utf8 file-lines ] [ drop f ] if ; - -: vocab-file-contents ( vocab name -- seq ) - vocab-append-path dup [ (vocab-file-contents) ] when ; +MEMO: vocab-file-contents ( vocab name -- seq ) + vocab-append-path dup + [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ; : set-vocab-file-contents ( seq vocab name -- ) dupd vocab-append-path [ utf8 set-file-lines - \ (vocab-file-contents) reset-memoized + \ vocab-file-contents reset-memoized ] [ "The " swap vocab-name " vocabulary was not loaded from the file system" @@ -261,7 +262,7 @@ MEMO: all-authors ( -- seq ) : reset-cache ( -- ) root-cache get-global clear-assoc - \ (vocab-file-contents) reset-memoized + \ vocab-file-contents reset-memoized \ all-vocabs-seq reset-memoized \ all-authors reset-memoized \ all-tags reset-memoized ; From 16fa44fc8222b15d81c6bb3295eb3a38b3835f2b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 00:22:25 -0500 Subject: [PATCH 604/886] Fix irc loading --- extra/irc/irc.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor index 0105fc53bb..27f82b25eb 100755 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays calendar combinators channels concurrency.messaging fry io io.encodings.8-bit io.sockets kernel math namespaces sequences - sequences.lib singleton splitting strings threads + sequences.lib splitting strings threads continuations classes.tuple ascii accessors ; IN: irc @@ -209,7 +209,7 @@ M: nick-in-use handle-irc ( obj -- ) { "KICK" [ \ kick ] } [ drop \ unhandled ] } case - [ [ tuple-slots ] [ parameters>> ] bi append ] dip add* >tuple ; + [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ; ! Reader : handle-reader-message ( irc-client irc-message -- ) From c5229fcbd1a1148545c47ec6caa57c83ecfd5b40 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 00:32:18 -0500 Subject: [PATCH 605/886] add some docs for environment variables --- core/system/system-docs.factor | 35 ++++++++++++++++++++++++++++------ 1 file changed, 29 insertions(+), 6 deletions(-) diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index df112bd786..d0b2cfb194 100755 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -7,9 +7,7 @@ ABOUT: "system" ARTICLE: "system" "System interface" { $subsection "cpu" } { $subsection "os" } -"Reading environment variables:" -{ $subsection os-env } -{ $subsection os-envs } +{ $subsection "environment-variables" } "Getting the path to the Factor VM and image:" { $subsection vm } { $subsection image } @@ -19,7 +17,16 @@ ARTICLE: "system" "System interface" { $subsection exit } { $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ; -ARTICLE: "cpu" "Processor Detection" +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:" @@ -30,7 +37,7 @@ ARTICLE: "cpu" "Processor Detection" "Processor families:" { $subsection x86 } ; -ARTICLE: "os" "Operating System Detection" +ARTICLE: "os" "Operating system detection" "Operating system detection:" { $subsection os } "Supported operating systems:" @@ -98,7 +105,23 @@ HELP: set-os-envs } { $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: 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." } ; + +{ os-env os-envs set-os-env unset-os-env set-os-envs } related-words HELP: image { $values { "path" "a pathname string" } } From d1cc5cc650461cff50e15ba4640f2e746e72dece Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 00:33:29 -0500 Subject: [PATCH 606/886] windows environment variables --- vm/os-windows.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/vm/os-windows.c b/vm/os-windows.c index b3fc1c917f..77a32f6f9f 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -217,17 +217,17 @@ void sleep_millis(DWORD msec) DEFINE_PRIMITIVE(set_os_env) { - char *key = unbox_char_string(); + F_CHAR *key = unbox_u16_string(); REGISTER_C_STRING(key); - char *value = unbox_char_string(); + F_CHAR *value = unbox_u16_string(); UNREGISTER_C_STRING(key); SetEnvironmentVariable(key, value); } DEFINE_PRIMITIVE(unset_os_env) { - char *key = unbox_char_string(); - SetEnvironmentVariable(key, f); + F_CHAR *key = unbox_u16_string(); + SetEnvironmentVariable(key, NULL); } DEFINE_PRIMITIVE(set_os_envs) From c6e1347c6718c793dbb7d3949c48147e2e2259d5 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Tue, 8 Apr 2008 22:36:49 -0700 Subject: [PATCH 607/886] Two small spelling fixes --- core/inference/backend/backend-docs.factor | 2 +- extra/io/monitors/monitors-docs.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor index 1d742e144a..32978d5814 100755 --- a/core/inference/backend/backend-docs.factor +++ b/core/inference/backend/backend-docs.factor @@ -4,7 +4,7 @@ kernel.private combinators sequences.private ; 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." } diff --git a/extra/io/monitors/monitors-docs.factor b/extra/io/monitors/monitors-docs.factor index 76a354b0bd..4f24879e19 100755 --- a/extra/io/monitors/monitors-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -9,7 +9,7 @@ $nl HELP: next-change { $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } } -{ $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" } "." } ; +{ $description "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" } "." } ; HELP: with-monitor { $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } } From 639871900a65a25617fed0ee19342e6cd4971dac Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Tue, 8 Apr 2008 23:22:28 -0700 Subject: [PATCH 608/886] Import extra/unionfind, a disjoint set datastructure --- extra/unionfind/authors.txt | 1 + extra/unionfind/summary.txt | 1 + extra/unionfind/unionfind.factor | 71 ++++++++++++++++++++++++++++++++ 3 files changed, 73 insertions(+) create mode 100644 extra/unionfind/authors.txt create mode 100644 extra/unionfind/summary.txt create mode 100644 extra/unionfind/unionfind.factor diff --git a/extra/unionfind/authors.txt b/extra/unionfind/authors.txt new file mode 100644 index 0000000000..16e1588016 --- /dev/null +++ b/extra/unionfind/authors.txt @@ -0,0 +1 @@ +Eric Mertens diff --git a/extra/unionfind/summary.txt b/extra/unionfind/summary.txt new file mode 100644 index 0000000000..c282cc29bb --- /dev/null +++ b/extra/unionfind/summary.txt @@ -0,0 +1 @@ +A efficient implementation of a disjoint-set datastructure diff --git a/extra/unionfind/unionfind.factor b/extra/unionfind/unionfind.factor new file mode 100644 index 0000000000..1f0d8be927 --- /dev/null +++ b/extra/unionfind/unionfind.factor @@ -0,0 +1,71 @@ +USING: accessors arrays combinators kernel math sequences namespaces ; + +IN: unionfind + +> nth ; + +: add-count ( p a -- ) + count [ + ] curry uf get counts>> swap change-nth ; + +: parent ( a -- p ) + uf get parents>> nth ; + +: set-parent ( p a -- ) + uf get parents>> set-nth ; + +: link-sets ( p a -- ) + [ set-parent ] + [ add-count ] 2bi ; + +: rank ( a -- r ) + uf get ranks>> nth ; + +: inc-rank ( a -- ) + uf get ranks>> [ 1+ ] change-nth ; + +: topparent ( a -- p ) + [ parent ] keep + 2dup = [ + [ topparent ] dip + 2dup set-parent + ] unless drop ; + +PRIVATE> + +: ( n -- unionfind ) + [ >array ] + [ 0 ] + [ 1 ] tri + unionfind construct-boa ; + +: equiv-set-size ( a uf -- n ) + uf [ topparent count ] with-variable ; + +: equiv? ( a b uf -- ? ) + uf [ [ topparent ] bi@ = ] with-variable ; + +: equate ( a b uf -- ) + uf [ + [ topparent ] bi@ + 2dup [ rank ] compare sgn + { + { -1 [ swap link-sets ] } + { 1 [ link-sets ] } + { 0 [ + 2dup = + [ 2drop ] + [ + [ link-sets ] + [ drop inc-rank ] 2bi + ] if + ] + } + } case + ] with-variable ; From 8d8c39ecca0496b8e684a810211c6f662ed0ac36 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 02:53:21 -0500 Subject: [PATCH 609/886] Fix circularity --- core/inference/backend/backend-docs.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor index 32978d5814..0125f04efa 100755 --- a/core/inference/backend/backend-docs.factor +++ b/core/inference/backend/backend-docs.factor @@ -1,6 +1,7 @@ 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." } From 6b16f7082257ab897c9d6e9f0a1cb54c618dbc6e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 02:53:29 -0500 Subject: [PATCH 610/886] Try a different strategy --- .../tools/vocabs/monitor/monitor-tests.factor | 6 +++++ extra/tools/vocabs/monitor/monitor.factor | 26 +++++++++++++------ 2 files changed, 24 insertions(+), 8 deletions(-) create mode 100644 extra/tools/vocabs/monitor/monitor-tests.factor diff --git a/extra/tools/vocabs/monitor/monitor-tests.factor b/extra/tools/vocabs/monitor/monitor-tests.factor new file mode 100644 index 0000000000..f1eece91c2 --- /dev/null +++ b/extra/tools/vocabs/monitor/monitor-tests.factor @@ -0,0 +1,6 @@ +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 diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index ada539c60a..b96f76d3ba 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -11,27 +11,37 @@ IN: tools.vocabs.monitor : path>vocab-name ( path -- vocab ) dup ".factor" tail? [ parent-directory ] when - dup [ vocab-dir>vocab-name ] when ; + ; + +: chop-vocab-root ( path -- path' ) + "resource:" prepend-path (normalize-path) + dup vocab-roots get + [ (normalize-path) ] map + [ head? ] with find nip + ?head drop ; + +: path>vocab ( path -- vocab ) + chop-vocab-root path>vocab-name vocab-dir>vocab-name ; : changed-vocab ( vocab -- ) dup vocab [ dup changed-vocabs get-global set-at ] [ drop ] if ; -: monitor-thread ( path monitor -- ) +: monitor-thread ( monitor -- ) #! On OS X, monitors give us the full path, so we chop it #! off if its there. - next-change drop swap ?head drop - path>vocab-name changed-vocab reset-cache ; + next-change drop path>vocab changed-vocab reset-cache ; -: start-monitor-thread ( root -- ) +: start-monitor-thread ( monitor -- ) #! Silently ignore errors during monitor creation since #! monitors are not supported on all platforms. - (normalize-path) dup t [ monitor-thread t ] 2curry - "Vocabulary monitor" spawn-server drop ; + [ monitor-thread t ] curry + "Vocabulary monitor" spawn-server + drop ; : start-monitor-threads ( -- ) [ - vocab-roots get [ start-monitor-thread ] each + "" resource-path t start-monitor-thread H{ } clone changed-vocabs set-global vocabs [ changed-vocab ] each ] ignore-errors ; From 17931bb5353c3ea994a1bc15890fa7510e93da7a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 02:56:17 -0500 Subject: [PATCH 611/886] Add command-line switch for disabling the refresh-all monitor --- extra/tools/vocabs/monitor/monitor.factor | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index b96f76d3ba..867c3b2903 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: threads io.files io.monitors init kernel vocabs vocabs.loader tools.vocabs namespaces continuations -sequences splitting assocs ; +sequences splitting assocs command-line ; IN: tools.vocabs.monitor : vocab-dir>vocab-name ( path -- vocab ) @@ -32,18 +32,20 @@ IN: tools.vocabs.monitor #! off if its there. next-change drop path>vocab changed-vocab reset-cache ; -: start-monitor-thread ( monitor -- ) +: start-monitor-thread ( -- ) #! Silently ignore errors during monitor creation since #! monitors are not supported on all platforms. - [ monitor-thread t ] curry - "Vocabulary monitor" spawn-server - drop ; - -: start-monitor-threads ( -- ) [ - "" resource-path t start-monitor-thread + "" resource-path t [ monitor-thread t ] curry + "Vocabulary monitor" spawn-server drop + H{ } clone changed-vocabs set-global + vocabs [ changed-vocab ] each ] ignore-errors ; -[ start-monitor-threads ] "tools.vocabs.monitor" add-init-hook +[ + "-no-monitors" cli-args get member? [ + start-monitor-thread + ] unless +] "tools.vocabs.monitor" add-init-hook From 5204d7065c25c8d73b00d9fa96756f9daac1dc0f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 03:00:15 -0500 Subject: [PATCH 612/886] Improve docs --- core/inference/inference-docs.factor | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index a837cfce5e..e32c94ed37 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -79,6 +79,18 @@ ARTICLE: "dataflow-graphs" "Inspecting the dataflow graph" "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 @@ -93,7 +105,8 @@ $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" } ; @@ -105,16 +118,7 @@ HELP: inference-error { $error-description "Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred." $nl - "The " { $snippet "error" } " slot contains 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" } "." } ; From 20148a1106dafacee41b5fc1f54d7ef76f3dfcc4 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Wed, 9 Apr 2008 01:20:45 -0700 Subject: [PATCH 613/886] Minor typo corrections in cookbook.factor --- extra/help/cookbook/cookbook.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index 075ce2d0e8..f1d4ac4ca7 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -224,7 +224,7 @@ $nl ":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" @@ -259,7 +259,7 @@ $nl { $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" @@ -273,7 +273,7 @@ $nl $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." + "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." @@ -285,7 +285,7 @@ $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." { "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. Imperitive programming and indexed loops are almost always not the most idiomatic solution." + "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." } @@ -312,7 +312,7 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid" $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." } } ; From 02886132f3b667d5eb03edb4a97a337d2f1f3ff4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 12:50:58 -0500 Subject: [PATCH 614/886] add [un]set-os-env tests --- core/system/system-tests.factor | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/core/system/system-tests.factor b/core/system/system-tests.factor index 14e34ccb17..d5a48080c2 100755 --- a/core/system/system-tests.factor +++ b/core/system/system-tests.factor @@ -12,3 +12,10 @@ os unix? [ [ ] [ "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 + From d748c367c0d373c4f6575931cfecb1f923c98a24 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 14:01:04 -0500 Subject: [PATCH 615/886] ppc64 architecture is now recognized --- build-support/factor.sh | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/build-support/factor.sh b/build-support/factor.sh index ea0c35aa83..4bcd9e3086 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -89,6 +89,11 @@ set_md5sum() { 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 } @@ -185,6 +190,7 @@ find_architecture() { i386) ARCH=x86;; i686) ARCH=x86;; amd64) ARCH=x86;; + ppc64) ARCH=ppc;; *86) ARCH=x86;; *86_64) ARCH=x86;; "Power Macintosh") ARCH=ppc;; From 409d984c3c35a233e25b7e3e90e563bf83e9c3b3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 16:57:21 -0500 Subject: [PATCH 616/886] move os_env from run to os-unix.c/os-windows.c --- vm/os-unix.c | 10 ++++++++++ vm/os-windows.c | 21 ++++++++++++++++++--- vm/run.c | 10 ---------- 3 files changed, 28 insertions(+), 13 deletions(-) diff --git a/vm/os-unix.c b/vm/os-unix.c index 2991cde78c..6363ce68a9 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -85,6 +85,16 @@ DEFINE_PRIMITIVE(read_dir) 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); diff --git a/vm/os-windows.c b/vm/os-windows.c index 77a32f6f9f..136168807a 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -215,19 +215,34 @@ void sleep_millis(DWORD msec) Sleep(msec); } +DEFINE_PRIMITIVE(os_env) +{ + F_CHAR *key = unbox_u16_string(); + F_CHAR *value = safe_malloc(MAX_UNICODE_PATH); + int ret; + ret = GetEnvironmentVariable(key, value, MAX_UNICODE_PATH); + 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); - SetEnvironmentVariable(key, value); + if(!SetEnvironmentVariable(key, value)) + general_error(ERROR_IO, tag_object(get_error_message()), F, NULL); } DEFINE_PRIMITIVE(unset_os_env) { - F_CHAR *key = unbox_u16_string(); - SetEnvironmentVariable(key, NULL); + 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) diff --git a/vm/run.c b/vm/run.c index 282be0a447..ae0c91d9e6 100755 --- a/vm/run.c +++ b/vm/run.c @@ -280,16 +280,6 @@ DEFINE_PRIMITIVE(exit) 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(); From 2da9aa9d18f529344a057f140aac10e2da96b3af Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 16:58:55 -0500 Subject: [PATCH 617/886] Fix Linux/PPC port --- vm/os-linux-ppc.h | 8 ++++++++ vm/os-macosx.h | 8 +++++++- vm/os-unix-ucontext.h | 7 ------- vm/platform.h | 2 -- 4 files changed, 15 insertions(+), 10 deletions(-) delete mode 100644 vm/os-unix-ucontext.h diff --git a/vm/os-linux-ppc.h b/vm/os-linux-ppc.h index 86f0509e38..eb28af53e4 100644 --- a/vm/os-linux-ppc.h +++ b/vm/os-linux-ppc.h @@ -1,4 +1,12 @@ +#include + #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]) diff --git a/vm/os-macosx.h b/vm/os-macosx.h index 4c35087752..701bb8da01 100644 --- a/vm/os-macosx.h +++ b/vm/os-macosx.h @@ -15,4 +15,10 @@ DLLEXPORT void c_to_factor_toplevel(CELL quot); #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; +} diff --git a/vm/os-unix-ucontext.h b/vm/os-unix-ucontext.h deleted file mode 100644 index 9ed0620a83..0000000000 --- a/vm/os-unix-ucontext.h +++ /dev/null @@ -1,7 +0,0 @@ -#include - -INLINE void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return ucontext->uc_stack.ss_sp; -} diff --git a/vm/platform.h b/vm/platform.h index a8c8ba756f..2f97cb9d1d 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -27,7 +27,6 @@ #include "os-unix.h" #ifdef __APPLE__ - #include "os-unix-ucontext.h" #include "os-macosx.h" #include "mach_signal.h" @@ -84,7 +83,6 @@ #if defined(FACTOR_X86) #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" From 9373df5c4c5614a4a45afa215b26d249d1390611 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 17:04:09 -0500 Subject: [PATCH 618/886] Fix -generations=1 --- vm/data_gc.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/data_gc.h b/vm/data_gc.h index d3b8b6e39e..2490ed8805 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -315,7 +315,7 @@ INLINE void* allot_object(CELL type, CELL a) { CELL *object; - if(nursery->size - ALLOT_BUFFER_ZONE > a) + 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) From f6e73abc0249e31bbd97918e285ccc851a043528 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 19:30:54 -0500 Subject: [PATCH 619/886] Redo refresh-all --- core/vocabs/loader/loader-tests.factor | 2 + extra/tools/vocabs/monitor/monitor.factor | 7 +- extra/tools/vocabs/vocabs.factor | 116 ++++++++++++++-------- 3 files changed, 80 insertions(+), 45 deletions(-) diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 1191594fe5..45b0d6b019 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -110,6 +110,8 @@ IN: vocabs.loader.tests ] 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 diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index 867c3b2903..826d410480 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -10,8 +10,7 @@ IN: tools.vocabs.monitor { { CHAR: / CHAR: . } { CHAR: \\ CHAR: . } } substitute ; : path>vocab-name ( path -- vocab ) - dup ".factor" tail? [ parent-directory ] when - ; + dup ".factor" tail? [ parent-directory ] when ; : chop-vocab-root ( path -- path' ) "resource:" prepend-path (normalize-path) @@ -23,10 +22,6 @@ IN: tools.vocabs.monitor : path>vocab ( path -- vocab ) chop-vocab-root path>vocab-name vocab-dir>vocab-name ; -: changed-vocab ( vocab -- ) - dup vocab - [ dup changed-vocabs get-global set-at ] [ drop ] if ; - : monitor-thread ( monitor -- ) #! On OS X, monitors give us the full path, so we chop it #! off if its there. diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 825d2a6329..211b396c50 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -32,43 +32,6 @@ IN: tools.vocabs [ vocab-tests % ] tri ] { } make ; -: source-modified? ( path -- ? ) - dup source-files get at [ - dup source-file-path - dup exists? [ - utf8 file-lines lines-crc32 - swap source-file-checksum = not - ] [ - 2drop f - ] if - ] [ - exists? - ] ?if ; - -: modified ( seq quot -- seq ) - [ dup ] swap compose { } map>assoc - [ nip ] assoc-subset - [ nip source-modified? ] assoc-subset keys ; inline - -: modified-sources ( vocabs -- seq ) - [ vocab-source-path ] modified ; - -: modified-docs ( vocabs -- seq ) - [ vocab-docs-path ] modified ; - -SYMBOL: changed-vocabs - -[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook - -: filter-changed ( vocabs -- vocabs' ) - changed-vocabs get [ - [ delete-at* nip ] curry subset - ] when* ; - -: to-refresh ( prefix -- modified-sources modified-docs ) - child-vocabs filter-changed - [ modified-sources ] [ modified-docs ] bi ; - : vocab-heading. ( vocab -- ) nl "==== " write @@ -95,12 +58,87 @@ SYMBOL: failures failures get ] with-compiler-errors ; -: do-refresh ( modified-sources modified-docs -- ) +: source-modified? ( path -- ? ) + dup source-files get at [ + dup source-file-path + dup exists? [ + utf8 file-lines lines-crc32 + swap source-file-checksum = not + ] [ + 2drop f + ] if + ] [ + exists? + ] ?if ; + +SYMBOL: changed-vocabs + +[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook + +: changed-vocab ( vocab -- ) + dup vocab + [ dup changed-vocabs get-global set-at ] [ drop ] if ; + +: unchanged-vocab ( vocab -- ) + changed-vocabs get-global delete-at ; + +: unchanged-vocabs ( vocabs -- ) + [ unchanged-vocab ] each ; + +: filter-changed ( vocabs -- vocabs' ) + changed-vocabs get [ + [ key? ] curry subset + ] when* ; + +SYMBOL: modified-sources +SYMBOL: modified-docs + +: (to-refresh) ( vocab variable loaded? path -- ) + dup [ + swap [ + pick changed-vocabs get key? [ + source-modified? [ get push ] [ 2drop ] if + ] [ 3drop ] if + ] [ drop get push ] if + ] [ 2drop 2drop ] if ; + +: to-refresh ( prefix -- modified-sources modified-docs unchanged ) + [ + V{ } clone modified-sources set + V{ } clone modified-docs set + + child-vocabs [ + [ + [ + [ modified-sources ] + [ vocab-source-loaded? ] + [ vocab-source-path ] + tri (to-refresh) + ] [ + [ modified-docs ] + [ vocab-docs-loaded? ] + [ vocab-docs-path ] + tri (to-refresh) + ] bi + ] each + + modified-sources get + modified-docs get + ] + [ modified-sources get modified-docs get append swap seq-diff ] bi + ] with-scope ; + +: do-refresh ( modified-sources modified-docs unchanged -- ) + unchanged-vocabs [ [ [ f swap set-vocab-source-loaded? ] each ] [ [ f swap set-vocab-docs-loaded? ] each ] bi* ] - [ append prune require-all load-failures. ] 2bi ; + [ + append prune + [ unchanged-vocabs ] + [ require-all load-failures. ] bi + ] 2bi ; : refresh ( prefix -- ) to-refresh do-refresh ; From 0e723f64cc2cd97e767cccab9f4b3a8ecb197385 Mon Sep 17 00:00:00 2001 From: slava Date: Wed, 9 Apr 2008 19:47:10 -0500 Subject: [PATCH 620/886] Add unit tests for monitors --- extra/io/monitors/monitors-tests.factor | 29 +++++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100644 extra/io/monitors/monitors-tests.factor diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor new file mode 100644 index 0000000000..fb687f6876 --- /dev/null +++ b/extra/io/monitors/monitors-tests.factor @@ -0,0 +1,29 @@ +IN: io.monitors.tests +USING: io.monitors tools.test io.files system sequences +continuations namespaces concurrency.count-downs kernel io +threads calendar ; + +os { winnt macosx linux } member? [ + [ "monitor-test" temp-file delete-tree ] ignore-errors + + [ ] [ "monitor-test" temp-file make-directory ] unit-test + + [ ] [ "monitor-test" temp-file t "m" set ] unit-test + + [ ] [ 1 "c" set ] unit-test + + [ ] [ + [ + [ + "m" get next-change drop + dup print flush + "test.txt" tail? not + ] [ ] [ ] while + "c" get count-down + ] "Monitor test thread" spawn drop + ] unit-test + + [ ] [ "monitor-test/test.txt" touch-file ] unit-test + + [ ] [ "c" get 30 seconds await-timeout ] unit-test +] when From b63edfd493bc13c424edd81f96752918115610a8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 19:54:48 -0500 Subject: [PATCH 621/886] Add unit tests for monitors --- extra/io/monitors/monitors-tests.factor | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index fb687f6876..4bb5db9f0a 100644 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -1,29 +1,34 @@ IN: io.monitors.tests USING: io.monitors tools.test io.files system sequences continuations namespaces concurrency.count-downs kernel io -threads calendar ; +threads calendar prettyprint ; os { winnt macosx linux } member? [ [ "monitor-test" temp-file delete-tree ] ignore-errors - [ ] [ "monitor-test" temp-file make-directory ] unit-test + [ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test [ ] [ "monitor-test" temp-file t "m" set ] unit-test + [ ] [ 1 "b" set ] unit-test + [ ] [ 1 "c" set ] unit-test [ ] [ [ + "b" get count-down [ "m" get next-change drop - dup print flush - "test.txt" tail? not + dup print flush right-trim-separators + "xyz" tail? not ] [ ] [ ] while "c" get count-down ] "Monitor test thread" spawn drop ] unit-test - [ ] [ "monitor-test/test.txt" touch-file ] unit-test + [ ] [ "b" get await ] unit-test + + [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test [ ] [ "c" get 30 seconds await-timeout ] unit-test ] when From 48a16b542d0f4e5e23956012194c4fe61d76c6b4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 20:14:14 -0500 Subject: [PATCH 622/886] Unit test fixes --- core/definitions/definitions-tests.factor | 20 -------------------- extra/io/monitors/monitors-tests.factor | 4 ++++ 2 files changed, 4 insertions(+), 20 deletions(-) diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index 3dc28139ea..b20d81ec7c 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -2,26 +2,6 @@ IN: definitions.tests USING: tools.test generic kernel definitions sequences compiler.units words ; -TUPLE: combination-1 ; - -M: combination-1 perform-combination drop [ ] define ; - -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 diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index 4bb5db9f0a..7170e824c8 100644 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -31,4 +31,8 @@ os { winnt macosx linux } member? [ [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test [ ] [ "c" get 30 seconds await-timeout ] unit-test + + [ ] [ "m" get dispose ] unit-test + + [ "m" get dispose ] must-fail ] when From 0c351581b5c299450e4d081bde4260ee294b36a1 Mon Sep 17 00:00:00 2001 From: slava Date: Wed, 9 Apr 2008 20:15:24 -0500 Subject: [PATCH 623/886] Fix -no-monitors switch --- extra/tools/vocabs/monitor/monitor.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index 867c3b2903..185f8d157a 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -45,7 +45,7 @@ IN: tools.vocabs.monitor ] ignore-errors ; [ - "-no-monitors" cli-args get member? [ + "-no-monitors" cli-args member? [ start-monitor-thread ] unless ] "tools.vocabs.monitor" add-init-hook From b4c9bbdf805bc79256bc6f21f47d07cac0829251 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 9 Apr 2008 21:01:00 -0500 Subject: [PATCH 624/886] processing: at-fraction --- extra/processing/processing.factor | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor index 02a8325663..0f21634dc8 100644 --- a/extra/processing/processing.factor +++ b/extra/processing/processing.factor @@ -8,7 +8,7 @@ USING: kernel namespaces threads combinators sequences arrays combinators combinators.lib combinators.cleave - rewrite-closures fry accessors + rewrite-closures fry accessors newfx processing.color processing.gadget ; @@ -28,6 +28,12 @@ IN: processing ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: at-fraction ( seq fraction -- val ) over length 1- * nth-at ; + +: at-fraction-of ( fraction seq -- val ) swap at-fraction ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + VAR: fill-color VAR: stroke-color @@ -282,7 +288,7 @@ VAR: frame-rate-value ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -VAR: slate +! VAR: slate VAR: loop-flag From a135aa479b9cf2c024e28a746dad0da9dea9093e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 9 Apr 2008 21:01:34 -0500 Subject: [PATCH 625/886] bubble-chamber: Refactoring --- .../bubble-chamber/bubble-chamber.factor | 207 ++++++++---------- 1 file changed, 91 insertions(+), 116 deletions(-) diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor index 2efa04efad..1a5fa37fa6 100644 --- a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor +++ b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor @@ -32,6 +32,8 @@ IN: processing.gallery.bubble-chamber : dim ( -- dim ) 1000 ; +: center ( -- point ) dim 2 / dup {2} ; foldable + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! VAR: collision-theta @@ -73,7 +75,7 @@ VARS: particles muons quarks hadrons axions ; T{ rgba f 0.47 0.42 0.56 1 } } ; -: good-color ( i -- color ) good-colors nth-of ; +: anti-colors ( -- seq ) good-colors ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -89,6 +91,26 @@ VARS: particles muons quarks hadrons axions ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: 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 } ] 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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -120,32 +142,36 @@ TUPLE: muon < particle ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: 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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + METHOD: collide { muon } - dim 2 / dup 2array >>pos - 2 32 [a,b] random >>speed - 0.0001 0.001 2random >>speed-d + 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 - [ dup theta-dd>> abs 0.001 < ] - [ -0.1 0.1 2random >>theta-dd ] - [ ] - while + [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while - dup theta>> pi + - 2 pi * / - good-colors length 1 - * - [ ] [ good-colors length >= ] [ 0 < ] tri or - [ drop ] - [ - [ good-color >>myc ] - [ good-colors length swap - 1 - good-color >>mya ] - bi - ] - if + set-good-color + set-anti-color drop ; @@ -163,14 +189,11 @@ METHOD: move { muon } [ speed>> ] [ theta>> { sin cos } ] bi n*v move-by - [ ] [ theta>> ] [ theta-d>> ] tri + >>theta - [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d - [ ] [ speed>> ] [ speed-d>> ] tri - >>speed + step-theta + step-theta-d + step-speed-sub - out-of-bounds? - [ collide ] - [ drop ] - if ; + out-of-bounds? [ collide ] [ drop ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -182,7 +205,7 @@ TUPLE: quark < particle ; METHOD: collide { quark } - dim 2 / dup 2array >>pos + center >>pos collision-theta> -0.11 0.11 2random + >>theta 0.5 3.0 2random >>speed @@ -190,10 +213,7 @@ METHOD: collide { quark } 0 >>theta-d 0 >>theta-dd - [ dup theta-dd>> abs 0.00001 < ] - [ -0.001 0.001 2random >>theta-dd ] - [ ] - while + [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while drop ; @@ -208,26 +228,20 @@ METHOD: move { quark } [ ] [ vel>> ] bi move-by - dup - [ speed>> ] [ theta>> { sin cos } ] bi n*v - >>vel + turn - [ ] [ theta>> ] [ theta-d>> ] tri + >>theta - [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d - [ ] [ speed>> ] [ speed-d>> ] tri * >>speed + step-theta + step-theta-d + step-speed-mul - ! 1000 random 997 > - 3/1000 chance + 1000 random 997 > [ dup speed>> neg >>speed 2 over speed-d>> - >>speed-d ] when - out-of-bounds? - [ collide ] - [ drop ] - if ; + out-of-bounds? [ collide ] [ drop ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -239,18 +253,14 @@ TUPLE: hadron < particle ; METHOD: collide { hadron } - dim 2 / dup 2array >>pos - 2 pi * 1random >>theta - 0.5 3.5 2random >>speed - + 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 - [ dup theta-dd>> abs 0.00001 < ] - [ -0.001 0.001 2random >>theta-dd ] - [ ] - while + [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while 0 1 0 >>myc @@ -268,34 +278,22 @@ METHOD: move { hadron } dup vel>> move-by - dup - [ speed>> ] [ theta>> { sin cos } ] bi n*v - >>vel + turn - [ ] [ theta>> ] [ theta-d>> ] tri + >>theta - [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d - [ ] [ speed>> ] [ speed-d>> ] tri * >>speed + step-theta + step-theta-d + step-speed-mul - ! 1000 random 997 > - 3/1000 chance + 1000 random 997 > [ 1.0 >>speed-d 0.00001 >>theta-dd - ! 100 random 70 > - 30/100 chance - [ - dim 2 / dup 2array >>pos - dup collide - ] - when + 100 random 70 > [ dup collide ] when ] when - out-of-bounds? - [ collide ] - [ drop ] - if ; + out-of-bounds? [ collide ] [ drop ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -307,82 +305,59 @@ TUPLE: axion < particle ; METHOD: collide { axion } - dim 2 / dup 2array >>pos - 2 pi * 1random >>theta - 1.0 6.0 2random >>speed - + 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 - [ dup theta-dd>> abs 0.00001 < ] - [ -0.001 0.001 2random >>theta-dd ] - [ ] - while + [ 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] - [| dy | - 1 30 dy 6 * - 255.0 / 2array stroke - dup pos>> 0 dy neg 2array v+ point - ] with-locals - each - - 1 4 [a,b] - [| dy | - 0 30 dy 6 * - 255.0 / 2array stroke - dup pos>> dy v+y point - ] with-locals - each + 1 4 [a,b] [ axion-white axion-point- ] each + 1 4 [a,b] [ axion-black axion-point+ ] each dup vel>> move-by - dup - [ speed>> ] [ theta>> { sin cos } ] bi n*v - >>vel + turn - [ ] [ theta>> ] [ theta-d>> ] tri + >>theta - [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d - [ ] [ speed>> ] [ speed-d>> ] tri * >>speed + step-theta + step-theta-d + step-speed-mul [ ] [ speed-d>> 0.9999 * ] bi >>speed-d - ! 1000 random 996 > - 4/1000 chance + 1000 random 996 > [ - dup speed>> neg >>speed + dup speed>> neg >>speed dup speed-d>> neg 2 + >>speed-d - ! 100 random 30 > - 70/100 chance - [ - dim 2 / dup 2array >>pos - collide - ] - [ drop ] - if + 100 random 30 > [ collide ] [ drop ] if ] [ drop ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : draw ( -- ) - -! boom> -! [ particles> [ move ] each ] -! when ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : collide-all ( -- ) 2 pi * 1random >collision-theta From 2a85901ccaa040bf0481108c43b12f22e4192dd7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 10 Apr 2008 19:35:06 -0500 Subject: [PATCH 626/886] add some windows messages --- extra/windows/messages/messages.factor | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/extra/windows/messages/messages.factor b/extra/windows/messages/messages.factor index 733071d197..3b0db96d63 100644 --- a/extra/windows/messages/messages.factor +++ b/extra/windows/messages/messages.factor @@ -1001,3 +1001,25 @@ windows-messages set-global : 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 From 2045f44ced34a546d215c872cda542171014a6dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 00:08:49 -0500 Subject: [PATCH 627/886] Fix RSS unit tests --- extra/rss/rss-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor index 7523d0509f..252defe99b 100755 --- a/extra/rss/rss-tests.factor +++ b/extra/rss/rss-tests.factor @@ -5,7 +5,7 @@ IN: rss.tests : load-news-file ( filename -- feed ) #! Load an news syndication file and process it, returning #! it as an feed tuple. - utf8 read-feed ; + utf8 file-contents read-feed ; [ T{ feed @@ -36,7 +36,7 @@ IN: rss.tests "http://example.org/2005/04/02/atom" "\n
\n

[Update: The Atom draft is finished.]

\n
\n " - T{ timestamp f 2003 12 13 8 29 29 -4 } + 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 From 2f2d31a623785b936e7fc7b18fc72af34ab0792e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 00:53:42 -0500 Subject: [PATCH 628/886] Fix HTTP unit tests --- extra/http/http-tests.factor | 15 +++++++++------ extra/http/http.factor | 3 +-- extra/http/server/actions/actions-tests.factor | 10 +++++++--- 3 files changed, 17 insertions(+), 11 deletions(-) diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 9302045624..3a50630335 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -24,6 +24,8 @@ IN: http.tests [ "/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 @@ -45,7 +47,7 @@ blah cookies: V{ } } ] [ - read-request-test-1 [ + read-request-test-1 lf>crlf [ read-request ] with-string-reader ] unit-test @@ -59,7 +61,7 @@ blah ; 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 @@ -69,6 +71,7 @@ read-request-test-1' 1array [ STRING: read-request-test-2 HEAD http://foo/bar HTTP/1.1 Host: www.sex.com + ; [ @@ -83,7 +86,7 @@ Host: www.sex.com cookies: V{ } } ] [ - read-request-test-2 [ + read-request-test-2 lf>crlf [ read-request ] with-string-reader ] unit-test @@ -104,7 +107,7 @@ blah cookies: V{ } } ] [ - read-response-test-1 + read-response-test-1 lf>crlf [ read-response ] with-string-reader ] unit-test @@ -117,7 +120,7 @@ content-type: text/html ; 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 @@ -162,7 +165,7 @@ io.encodings.ascii ; "localhost" 1237 ascii [ "GET nested HTTP/1.0\r\n" write flush "\r\n" write flush - readln drop + read-crlf drop read-header ] with-stream "location" swap at "/" head? ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 4aaab2205e..3e81fccd24 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -89,8 +89,7 @@ IN: http : read-crlf ( -- string ) "\r" read-until - CHAR: \r assert= - read1 CHAR: \n assert= ; + [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ; : read-header-line ( -- ) read-crlf dup diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor index ebf8e8770b..90e632d7f5 100755 --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/http/server/actions/actions-tests.factor @@ -1,7 +1,7 @@ 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 @@ -13,6 +13,8 @@ io.streams.string http.server sequences accessors ; { { "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 @@ -20,7 +22,8 @@ blah ; [ 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 @@ -40,7 +43,8 @@ xxx=4 ; [ "/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 From 3be7f29b25c5a939521b0f1b61de480237dd921c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 00:54:41 -0500 Subject: [PATCH 629/886] Fix todo load error --- extra/webapps/todo/todo.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 08555b92ed..97af356dc5 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -6,6 +6,7 @@ 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 @@ -78,8 +79,6 @@ TUPLE: todo-responder < dispatcher ; : init-todo ( -- ) test-db [ init-todo-table - init-users-table - init-sessions-table ] with-db From 04e9b1c37fb0c72f06e86e1ba2a42ae8e56a6ea2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 01:31:32 -0500 Subject: [PATCH 630/886] Fix Cocoa UI bug --- extra/ui/cocoa/views/views.factor | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor index 5b975f40de..442eda90ef 100755 --- a/extra/ui/cocoa/views/views.factor +++ b/extra/ui/cocoa/views/views.factor @@ -126,6 +126,13 @@ CLASS: { { +name+ "FactorView" } { +protocols+ { "NSTextInput" } } } + +! Rendering +! Rendering +{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" } + [ 3drop window relayout-1 ] +} + ! Events { "acceptsFirstMouse:" "bool" { "id" "SEL" "id" } [ 3drop 1 ] From 3a69c972980251af21c731f771d0e61625593bb9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 01:42:30 -0500 Subject: [PATCH 631/886] https:// is absolute --- extra/http/client/client.factor | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 8879a76a5c..cc356ca8e3 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -39,13 +39,16 @@ DEFER: http-request 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 redirects inc redirects get max-redirects < [ header>> "location" swap at - dup "http://" head? [ + dup absolute-url? [ absolute-redirect ] [ relative-redirect @@ -116,8 +119,12 @@ M: download-failed error. : download-to ( url file -- ) #! Downloads the contents of a URL to a file. - swap http-get-stream swap check-response - [ swap latin1 stream-copy ] with-disposal ; + swap http-get-stream check-response + dup string? [ + latin1 [ write ] with-file-writer + ] [ + [ swap latin1 stream-copy ] with-disposal + ] if ; : download ( url -- ) dup download-name download-to ; From df41c8b68f44a04209ef484a8f689f358266159c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 02:46:35 -0500 Subject: [PATCH 632/886] Fix documentation --- core/alien/strings/strings-docs.factor | 4 ++-- core/alien/strings/strings.factor | 2 +- extra/bit-vectors/bit-vectors-docs.factor | 4 ++-- extra/byte-vectors/byte-vectors-docs.factor | 2 +- extra/columns/columns-docs.factor | 2 +- extra/float-vectors/float-vectors-docs.factor | 4 ++-- 6 files changed, 9 insertions(+), 9 deletions(-) diff --git a/core/alien/strings/strings-docs.factor b/core/alien/strings/strings-docs.factor index 0dbb4ffd38..27b0122ebe 100644 --- a/core/alien/strings/strings-docs.factor +++ b/core/alien/strings/strings-docs.factor @@ -3,14 +3,14 @@ debugger ; IN: alien.strings HELP: string>alien -{ $values { "string" string } { "encoding" "an encoding descriptor" } { "array" byte-array } } +{ $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" 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 diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor index 463fc11e0d..d69d8e9e8e 100644 --- a/core/alien/strings/strings.factor +++ b/core/alien/strings/strings.factor @@ -6,7 +6,7 @@ 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 ( alien encoding -- string/f ) +GENERIC# alien>string 1 ( c-ptr encoding -- string/f ) M: c-ptr alien>string >r r> diff --git a/extra/bit-vectors/bit-vectors-docs.factor b/extra/bit-vectors/bit-vectors-docs.factor index 9ceb2df342..41f32b4cdb 100755 --- a/extra/bit-vectors/bit-vectors-docs.factor +++ b/extra/bit-vectors/bit-vectors-docs.factor @@ -3,7 +3,7 @@ bit-vectors.private combinators ; IN: bit-vectors ARTICLE: "bit-vectors" "Bit vectors" -"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." +"A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary." $nl "Bit vectors form a class:" { $subsection bit-vector } @@ -19,7 +19,7 @@ $nl ABOUT: "bit-vectors" HELP: bit-vector -{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ; +{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ; HELP: { $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } } diff --git a/extra/byte-vectors/byte-vectors-docs.factor b/extra/byte-vectors/byte-vectors-docs.factor index f34bc20219..139cbab822 100755 --- a/extra/byte-vectors/byte-vectors-docs.factor +++ b/extra/byte-vectors/byte-vectors-docs.factor @@ -19,7 +19,7 @@ $nl ABOUT: "byte-vectors" HELP: byte-vector -{ $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ; +{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ; HELP: { $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } } diff --git a/extra/columns/columns-docs.factor b/extra/columns/columns-docs.factor index 6b2adce9d9..a2f0cccf3b 100644 --- a/extra/columns/columns-docs.factor +++ b/extra/columns/columns-docs.factor @@ -14,7 +14,7 @@ HELP: ( seq n -- 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 ;" + "USING: arrays prettyprint columns ;" "{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 >array ." "{ 1 4 7 }" } diff --git a/extra/float-vectors/float-vectors-docs.factor b/extra/float-vectors/float-vectors-docs.factor index 8d25da54be..5e06f05a2b 100755 --- a/extra/float-vectors/float-vectors-docs.factor +++ b/extra/float-vectors/float-vectors-docs.factor @@ -3,7 +3,7 @@ float-vectors.private combinators ; IN: float-vectors ARTICLE: "float-vectors" "Float vectors" -"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." +"A float vector is a resizable mutable sequence of unsigned floats. Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary." $nl "Float vectors form a class:" { $subsection float-vector } @@ -19,7 +19,7 @@ $nl ABOUT: "float-vectors" HELP: float-vector -{ $description "The class of resizable float vectors. See " { $link "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general information." } ; +{ $description "The class of resizable float vectors. See " { $link "float-vectors" } " for information." } ; HELP: { $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } } From d2d2c5d84fbf6eaa2c5150067fd19dc8f6a314c6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 10 Apr 2008 20:00:04 -0500 Subject: [PATCH 633/886] fix using in hardware-info --- extra/hardware-info/windows/windows.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index 10474c09f7..3162496974 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -1,7 +1,7 @@ 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 ) From 8a0909d84923ce59a47e5322e449eb1c149d2768 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 10 Apr 2008 20:09:36 -0500 Subject: [PATCH 634/886] fix ffi test int ffi test 36 point 5 --- core/alien/compiler/compiler-tests.factor | 750 +++++++++++----------- vm/ffi_test.c | 2 +- 2 files changed, 376 insertions(+), 376 deletions(-) diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index 3d0f36e415..57bf163443 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -1,375 +1,375 @@ -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" [ 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" - [ 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 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" - 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" - 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" - 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" - 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" - [ 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 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 +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" [ 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" + [ 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 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" + 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" + 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" + 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" + 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" + [ 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 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 int_ffi_test_36_point_5 ( ) ; + +[ ] [ int_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 diff --git a/vm/ffi_test.c b/vm/ffi_test.c index b2cbf9b6b5..4293a6bbae 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -253,7 +253,7 @@ double ffi_test_36(struct test_struct_12 x) static int global_var; -void ffi_test_36_point_5(void) +void int_ffi_test_36_point_5(void) { printf("int_ffi_test_36_point_5\n"); global_var = 0; From 2cefe124d6c9c05b2b2dea665e7609ed63b85b3a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 10 Apr 2008 21:17:23 -0500 Subject: [PATCH 635/886] try not to render to factor windows when they're minimized --- extra/ui/windows/windows.factor | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index e0c9f24122..0adfc676f8 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -7,7 +7,7 @@ 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 ; +locals symbols accessors ; IN: ui.windows SINGLETON: windows-ui-backend @@ -203,8 +203,18 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; wParam keystroke>gesture 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* From 688cbfaafacf383374b162d6163ca957f7b84032 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 11 Apr 2008 14:46:11 +1200 Subject: [PATCH 636/886] Delocalise grow-lr --- extra/peg/peg.factor | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 7390c15684..164f7c9ee9 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -100,21 +100,21 @@ C: peg-head : setup-growth ( h p -- ) pos set dup involved-set>> clone >>eval-set drop ; -:: (grow-lr) ( h p r m -- ) - h p setup-growth - r eval-rule - dup m stop-growth? [ - 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 ] [ - m update-m - h p r m (grow-lr) + over update-m + (grow-lr) ] if ; inline -:: grow-lr ( h p r m -- ast ) - h p heads get set-at - h p r m (grow-lr) - p heads get delete-at - m pos>> pos set m ans>> +: 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 -- ) From a1b050fd88f5b3d3ba0a5b031dd1156d318e5b6a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 10 Apr 2008 21:49:08 -0500 Subject: [PATCH 637/886] Fix interactor --- .../tools/interactor/interactor-tests.factor | 25 ++++++++++++++++++- extra/ui/tools/interactor/interactor.factor | 4 ++- 2 files changed, 27 insertions(+), 2 deletions(-) diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor index fe0a654217..94953f9c72 100755 --- a/extra/ui/tools/interactor/interactor-tests.factor +++ b/extra/ui/tools/interactor/interactor-tests.factor @@ -1,4 +1,27 @@ 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 ; \ must-infer + +[ ] [ "interactor" set ] unit-test + +[ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test + +[ ] [ "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 diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index 8232094e76..86ba51df95 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -138,7 +138,9 @@ M: interactor stream-read-partial 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 ? ) From 039c344e8745bc0f1a5afb975c0c57eb14eb1ea8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 10 Apr 2008 22:02:23 -0500 Subject: [PATCH 638/886] Fix unit test failure on BSD --- extra/tools/vocabs/vocabs-tests.factor | 8 ++++++++ extra/tools/vocabs/vocabs.factor | 6 +++--- 2 files changed, 11 insertions(+), 3 deletions(-) create mode 100644 extra/tools/vocabs/vocabs-tests.factor diff --git a/extra/tools/vocabs/vocabs-tests.factor b/extra/tools/vocabs/vocabs-tests.factor new file mode 100644 index 0000000000..ae74d516e4 --- /dev/null +++ b/extra/tools/vocabs/vocabs-tests.factor @@ -0,0 +1,8 @@ +IN: tools.vocabs.tests +USING: tools.test tools.vocabs namespaces continuations ; + +[ ] [ + changed-vocabs get-global + f changed-vocabs set-global + [ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup +] unit-test diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 211b396c50..371bbc7813 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -76,11 +76,11 @@ SYMBOL: changed-vocabs [ f changed-vocabs set-global ] "tools.vocabs" add-init-hook : changed-vocab ( vocab -- ) - dup vocab - [ dup changed-vocabs get-global set-at ] [ drop ] if ; + dup vocab changed-vocabs get and + [ dup changed-vocabs get set-at ] [ drop ] if ; : unchanged-vocab ( vocab -- ) - changed-vocabs get-global delete-at ; + changed-vocabs get delete-at ; : unchanged-vocabs ( vocabs -- ) [ unchanged-vocab ] each ; From 1214f7e71334b2e355488471231b2f27d6c759ea Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 10 Apr 2008 22:31:12 -0500 Subject: [PATCH 639/886] newfx: Move to generics for getters and setters --- extra/newfx/newfx.factor | 91 +++++++++++++++++++++++++++++++--------- 1 file changed, 72 insertions(+), 19 deletions(-) diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index b123fef2a3..3df3b3ed05 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -1,56 +1,109 @@ 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 ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: nth-at ( seq i -- val ) swap nth ; -: nth-of ( i seq -- val ) nth ; +GENERIC: grab ( col key -- col val ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: nth-is ( seq i val -- seq ) swap pick set-nth ; -: is-nth ( seq val i -- seq ) pick set-nth ; +GENERIC: is ( col key val -- col ) +GENERIC: as ( col val key -- col ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: nth-is-of ( i val seq -- seq ) dup >r swapd set-nth r> ; -: is-nth-of ( val i seq -- seq ) dup >r set-nth r> ; +GENERIC: is-of ( key val col -- col ) +GENERIC: as-of ( val key col -- col ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: mutate-nth ( seq i val -- ) swap rot set-nth ; -: mutate-nth-at ( seq val i -- ) rot set-nth ; - -: mutate-nth-of ( i val seq -- ) swapd set-nth ; -: mutate-nth-at-of ( val i seq -- ) set-nth ; +GENERIC: mutate-at ( col key val -- ) +GENERIC: mutate-as ( col val key -- ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: at-key ( tbl key -- val ) swap at ; -: key-of ( key tbl -- val ) at ; +GENERIC: at-mutate ( key val col -- ) +GENERIC: as-mutate ( val key col -- ) + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! sequence +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: at { sequence number } swap nth ; +METHOD: of { number sequence } nth ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: key-is ( tbl key val -- tbl ) swap pick set-at ; -: is-key ( tbl val key -- tbl ) pick set-at ; +METHOD: grab { sequence number } dupd swap nth ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: mutate-key ( tbl key val -- ) swap rot set-at ; -: mutate-at-key ( tbl val key -- ) rot set-at ; +METHOD: is { sequence number object } swap pick set-nth ; +METHOD: as { sequence object number } pick set-nth ; -: mutate-key-of ( key val tbl -- ) swapd set-at ; -: mutate-at-key-of ( val key tbl -- ) set-at ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From c71a46d15e23881c57a4359bf28e703ab0ea3978 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 10 Apr 2008 22:33:22 -0500 Subject: [PATCH 640/886] Remove bubble-chamber from gallery (moving to root) --- .../bubble-chamber/bubble-chamber-docs.factor | 97 ---- .../bubble-chamber/bubble-chamber.factor | 428 ------------------ 2 files changed, 525 deletions(-) delete mode 100644 extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor delete mode 100644 extra/processing/gallery/bubble-chamber/bubble-chamber.factor diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor deleted file mode 100644 index 21a845e089..0000000000 --- a/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor +++ /dev/null @@ -1,97 +0,0 @@ - -USING: help.syntax help.markup ; - -IN: processing.gallery.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 diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor deleted file mode 100644 index 1a5fa37fa6..0000000000 --- a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor +++ /dev/null @@ -1,428 +0,0 @@ - -USING: kernel namespaces sequences combinators arrays threads - - math - math.libm - math.vectors - math.ranges - math.constants - math.functions - math.points - - ui - ui.gadgets - - random accessors multi-methods - combinators.cleave - vars locals - - newfx - - processing - processing.gadget - processing.color ; - -IN: processing.gallery.bubble-chamber - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: move-by ( obj delta -- obj ) over pos>> v+ >>pos ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: dim ( -- dim ) 1000 ; - -: center ( -- point ) dim 2 / dup {2} ; foldable - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -VAR: collision-theta - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -VAR: boom - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -VARS: particles muons quarks hadrons axions ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: 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 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: 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 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: 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 } ] 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 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -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 >>myc - 0 0 0 1 >>mya ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -GENERIC: collide ( particle -- ) -GENERIC: move ( particle -- ) - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: muon < particle ; - -: ( -- muon ) muon construct-empty initialize-particle ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: 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 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -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 } ] bi n*v - move-by - - step-theta - step-theta-d - step-speed-sub - - out-of-bounds? [ collide ] [ drop ] if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: quark < particle ; - -: ( -- quark ) quark construct-empty 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 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: hadron < particle ; - -: ( -- hadron ) hadron construct-empty 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 >>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 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: axion < particle ; - -: ( -- axion ) axion construct-empty 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 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: 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 ] map >muons - 1300 [ drop ] map >quarks - 1000 [ drop ] map >hadrons - 111 [ drop ] 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 From bbf5234a9e1442d0561bc9b5e54ac99b7e742f0c Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 10 Apr 2008 22:34:26 -0500 Subject: [PATCH 641/886] processing: use 'at' --- extra/processing/processing.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor index 0f21634dc8..e089b15e7e 100644 --- a/extra/processing/processing.factor +++ b/extra/processing/processing.factor @@ -28,7 +28,9 @@ IN: processing ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: at-fraction ( seq fraction -- val ) over length 1- * nth-at ; +! : 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 ; From cd9c92d9011b6675a2c4607c5cbece8ed051cbfa Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 10 Apr 2008 22:34:43 -0500 Subject: [PATCH 642/886] bubble-chamber: big refactoring --- extra/bubble-chamber/bubble-chamber.factor | 88 +++++++++++++++++++ extra/bubble-chamber/common/common.factor | 12 +++ .../particle/axion/axion.factor | 67 ++++++++++++++ .../particle/hadron/hadron.factor | 60 +++++++++++++ .../particle/muon/colors/colors.factor | 53 +++++++++++ .../bubble-chamber/particle/muon/muon.factor | 62 +++++++++++++ extra/bubble-chamber/particle/particle.factor | 68 ++++++++++++++ .../particle/quark/quark.factor | 53 +++++++++++ 8 files changed, 463 insertions(+) create mode 100644 extra/bubble-chamber/bubble-chamber.factor create mode 100644 extra/bubble-chamber/common/common.factor create mode 100644 extra/bubble-chamber/particle/axion/axion.factor create mode 100644 extra/bubble-chamber/particle/hadron/hadron.factor create mode 100644 extra/bubble-chamber/particle/muon/colors/colors.factor create mode 100644 extra/bubble-chamber/particle/muon/muon.factor create mode 100644 extra/bubble-chamber/particle/particle.factor create mode 100644 extra/bubble-chamber/particle/quark/quark.factor diff --git a/extra/bubble-chamber/bubble-chamber.factor b/extra/bubble-chamber/bubble-chamber.factor new file mode 100644 index 0000000000..4b0db46c35 --- /dev/null +++ b/extra/bubble-chamber/bubble-chamber.factor @@ -0,0 +1,88 @@ + +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 ] map >muons + 1300 [ drop ] map >quarks + 1000 [ drop ] map >hadrons + 111 [ drop ] 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 diff --git a/extra/bubble-chamber/common/common.factor b/extra/bubble-chamber/common/common.factor new file mode 100644 index 0000000000..c9ce687535 --- /dev/null +++ b/extra/bubble-chamber/common/common.factor @@ -0,0 +1,12 @@ + +USING: kernel math accessors combinators.cleave vars ; + +IN: bubble-chamber.common + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: collision-theta + +: dim ( -- dim ) 1000 ; + +: center ( -- point ) dim 2 / dup {2} ; foldable diff --git a/extra/bubble-chamber/particle/axion/axion.factor b/extra/bubble-chamber/particle/axion/axion.factor new file mode 100644 index 0000000000..9e9bf99272 --- /dev/null +++ b/extra/bubble-chamber/particle/axion/axion.factor @@ -0,0 +1,67 @@ + +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 construct-empty 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 ; diff --git a/extra/bubble-chamber/particle/hadron/hadron.factor b/extra/bubble-chamber/particle/hadron/hadron.factor new file mode 100644 index 0000000000..2994577838 --- /dev/null +++ b/extra/bubble-chamber/particle/hadron/hadron.factor @@ -0,0 +1,60 @@ + +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 construct-empty 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 >>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 ; diff --git a/extra/bubble-chamber/particle/muon/colors/colors.factor b/extra/bubble-chamber/particle/muon/colors/colors.factor new file mode 100644 index 0000000000..ab72f65b4b --- /dev/null +++ b/extra/bubble-chamber/particle/muon/colors/colors.factor @@ -0,0 +1,53 @@ + +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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: 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 ; diff --git a/extra/bubble-chamber/particle/muon/muon.factor b/extra/bubble-chamber/particle/muon/muon.factor new file mode 100644 index 0000000000..44c7d9f134 --- /dev/null +++ b/extra/bubble-chamber/particle/muon/muon.factor @@ -0,0 +1,62 @@ + +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 construct-empty 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 } ] bi n*v + move-by + + step-theta + step-theta-d + step-speed-sub + + out-of-bounds? [ collide ] [ drop ] if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/extra/bubble-chamber/particle/particle.factor b/extra/bubble-chamber/particle/particle.factor new file mode 100644 index 0000000000..755a414b71 --- /dev/null +++ b/extra/bubble-chamber/particle/particle.factor @@ -0,0 +1,68 @@ + +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 >>myc + 0 0 0 1 >>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 } ] 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 ; diff --git a/extra/bubble-chamber/particle/quark/quark.factor b/extra/bubble-chamber/particle/quark/quark.factor new file mode 100644 index 0000000000..32d95c8f00 --- /dev/null +++ b/extra/bubble-chamber/particle/quark/quark.factor @@ -0,0 +1,53 @@ + +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 construct-empty 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 ; From 56892ae74afe8b3050615380c8fc01e77521e4a4 Mon Sep 17 00:00:00 2001 From: slava Date: Fri, 11 Apr 2008 07:15:26 -0500 Subject: [PATCH 643/886] Overhaul monitors --- core/continuations/continuations-docs.factor | 6 +- core/io/files/files-docs.factor | 3 +- core/threads/threads.factor | 58 ++++---- .../mailboxes/mailboxes-docs.factor | 4 +- .../mailboxes/mailboxes-tests.factor | 39 +++++- extra/concurrency/mailboxes/mailboxes.factor | 46 +++++-- .../messaging/messaging-docs.factor | 5 +- .../messaging/messaging-tests.factor | 16 ++- extra/io/monitors/monitors-docs.factor | 84 +++++++++--- extra/io/monitors/monitors-tests.factor | 99 ++++++++++---- extra/io/monitors/monitors.factor | 92 ++++--------- .../monitors/recursive/recursive-tests.factor | 59 ++++++++ extra/io/monitors/recursive/recursive.factor | 105 ++++++++++++++ extra/io/timeouts/timeouts-docs.factor | 4 +- extra/io/unix/linux/linux.factor | 121 +--------------- extra/io/unix/linux/monitors/monitors.factor | 129 ++++++++++++++++++ extra/io/unix/macosx/macosx.factor | 19 ++- extra/io/unix/select/select.factor | 7 +- extra/tools/threads/threads.factor | 2 +- extra/tools/vocabs/monitor/monitor.factor | 27 ++-- extra/tools/vocabs/vocabs-tests.factor | 1 + extra/tools/vocabs/vocabs.factor | 9 +- 22 files changed, 627 insertions(+), 308 deletions(-) create mode 100644 extra/io/monitors/recursive/recursive-tests.factor create mode 100644 extra/io/monitors/recursive/recursive.factor create mode 100644 extra/io/unix/linux/monitors/monitors.factor diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index b3adb1b165..b1db09b6bc 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -90,7 +90,11 @@ 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 diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index e3f86c079d..0d49e344a8 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -112,8 +112,7 @@ ARTICLE: "io.files" "Basic file operations" { $subsection "file-streams" } { $subsection "fs-meta" } { $subsection "directories" } -{ $subsection "delete-move-copy" } -{ $see-also "os" } ; +{ $subsection "delete-move-copy" } ; ABOUT: "io.files" diff --git a/core/threads/threads.factor b/core/threads/threads.factor index d7d7988893..ba8f4f2e52 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -4,7 +4,7 @@ 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 @@ -18,11 +18,10 @@ mailbox variables sleep-entry ; ! 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 ; @@ -35,7 +34,7 @@ mailbox variables sleep-entry ; : thread ( id -- thread ) threads at ; : thread-registered? ( thread -- ? ) - thread-id threads key? ; + id>> threads key? ; : check-unregistered dup thread-registered? @@ -48,38 +47,37 @@ mailbox variables sleep-entry ; > 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> : ( quot name -- thread ) - \ thread counter [ ] { - set-thread-quot - set-thread-name - set-thread-id - set-thread-continuation - set-thread-exit-handler - } \ thread construct ; + \ thread construct-empty + swap >>name + swap >>quot + \ thread counter >>id + >>continuation + [ ] >>exit-handler ; : 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 ) @@ -93,14 +91,14 @@ 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 @@ -123,21 +121,21 @@ PRIVATE> ] [ 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 @@ -157,9 +155,9 @@ M: real sleep 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 ; @@ -171,7 +169,7 @@ M: real sleep 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 ; @@ -196,8 +194,8 @@ GENERIC: error-in-thread ( error thread -- ) 43 setenv initial-thread global [ drop f "Initial" ] cache - over set-thread-continuation - f over set-thread-state + >>continuation + f >>state dup register-thread set-self ; diff --git a/extra/concurrency/mailboxes/mailboxes-docs.factor b/extra/concurrency/mailboxes/mailboxes-docs.factor index 50694776c5..a9b86e3bcd 100755 --- a/extra/concurrency/mailboxes/mailboxes-docs.factor +++ b/extra/concurrency/mailboxes/mailboxes-docs.factor @@ -57,7 +57,7 @@ HELP: mailbox-get? ARTICLE: "concurrency.mailboxes" "Mailboxes" -"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." +"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." { $subsection mailbox } { $subsection } "Removing the first element:" @@ -73,3 +73,5 @@ ARTICLE: "concurrency.mailboxes" "Mailboxes" "Testing if a mailbox is empty:" { $subsection mailbox-empty? } { $subsection while-mailbox-empty } ; + +ABOUT: "concurrency.mailboxes" diff --git a/extra/concurrency/mailboxes/mailboxes-tests.factor b/extra/concurrency/mailboxes/mailboxes-tests.factor index 2cb12bcaba..7fe09cdcf5 100755 --- a/extra/concurrency/mailboxes/mailboxes-tests.factor +++ b/extra/concurrency/mailboxes/mailboxes-tests.factor @@ -1,6 +1,7 @@ IN: concurrency.mailboxes.tests -USING: concurrency.mailboxes vectors sequences threads -tools.test math kernel strings ; +USING: concurrency.mailboxes concurrency.count-downs vectors +sequences threads tools.test math kernel strings namespaces +continuations calendar ; [ V{ 1 2 3 } ] [ 0 @@ -38,3 +39,37 @@ tools.test math kernel strings ; "junk2" over mailbox-put mailbox-get ] unit-test + + "m" set + +1 "c" set +1 "d" set + +[ + "c" get await + [ "m" get mailbox-get drop ] + [ drop "d" get count-down ] recover +] "Mailbox close test" spawn drop + +[ ] [ "c" get count-down ] unit-test +[ ] [ "m" get dispose ] unit-test +[ ] [ "d" get 5 seconds await-timeout ] unit-test + +[ ] [ "m" get dispose ] unit-test + + "m" set + +1 "c" set +1 "d" set + +[ + "c" get await + "m" get wait-for-close + "d" get count-down +] "Mailbox close test" spawn drop + +[ ] [ "c" get count-down ] unit-test +[ ] [ "m" get dispose ] unit-test +[ ] [ "d" get 5 seconds await-timeout ] unit-test + +[ ] [ "m" get dispose ] unit-test diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index 7b6405679f..36aafbdc84 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -3,41 +3,50 @@ IN: concurrency.mailboxes USING: dlists threads sequences continuations namespaces random math quotations words kernel arrays assocs -init system concurrency.conditions ; +init system concurrency.conditions accessors ; -TUPLE: mailbox threads data ; +TUPLE: mailbox threads data closed ; + +: check-closed ( mailbox -- ) + closed>> [ "Mailbox closed" throw ] when ; inline + +M: mailbox dispose + t >>closed threads>> notify-all ; : ( -- mailbox ) - mailbox construct-boa ; + f mailbox construct-boa ; : mailbox-empty? ( mailbox -- bool ) - mailbox-data dlist-empty? ; + data>> dlist-empty? ; : mailbox-put ( obj mailbox -- ) - [ mailbox-data push-front ] keep - mailbox-threads notify-all yield ; + [ data>> push-front ] + [ threads>> notify-all ] bi yield ; + +: wait-for-mailbox ( mailbox timeout -- ) + >r threads>> r> "mailbox" wait ; : block-unless-pred ( mailbox timeout pred -- ) - pick mailbox-data over dlist-contains? [ + pick check-closed + pick data>> over dlist-contains? [ 3drop ] [ - >r over mailbox-threads over "mailbox" wait r> - block-unless-pred + >r 2dup wait-for-mailbox r> block-unless-pred ] if ; inline : block-if-empty ( mailbox timeout -- mailbox ) + over check-closed over mailbox-empty? [ - over mailbox-threads over "mailbox" wait - block-if-empty + 2dup wait-for-mailbox block-if-empty ] [ drop ] if ; : mailbox-peek ( mailbox -- obj ) - mailbox-data peek-back ; + data>> peek-back ; : mailbox-get-timeout ( mailbox timeout -- obj ) - block-if-empty mailbox-data pop-back ; + block-if-empty data>> pop-back ; : mailbox-get ( mailbox -- obj ) f mailbox-get-timeout ; @@ -45,7 +54,7 @@ TUPLE: mailbox threads data ; : mailbox-get-all-timeout ( mailbox timeout -- array ) block-if-empty [ dup mailbox-empty? ] - [ dup mailbox-data pop-back ] + [ dup data>> pop-back ] [ ] unfold nip ; : mailbox-get-all ( mailbox -- array ) @@ -60,11 +69,18 @@ TUPLE: mailbox threads data ; : mailbox-get-timeout? ( mailbox timeout pred -- obj ) 3dup block-unless-pred - nip >r mailbox-data r> delete-node-if ; inline + nip >r data>> r> delete-node-if ; inline : mailbox-get? ( mailbox pred -- obj ) f swap mailbox-get-timeout? ; inline +: wait-for-close-timeout ( mailbox timeout -- ) + over closed>> + [ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ; + +: wait-for-close ( mailbox -- ) + f wait-for-close-timeout ; + TUPLE: linked-error thread ; : ( error thread -- linked ) diff --git a/extra/concurrency/messaging/messaging-docs.factor b/extra/concurrency/messaging/messaging-docs.factor index e7aa5d1a7e..1219982f51 100755 --- a/extra/concurrency/messaging/messaging-docs.factor +++ b/extra/concurrency/messaging/messaging-docs.factor @@ -32,7 +32,7 @@ HELP: spawn-linked { $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." @@ -43,7 +43,8 @@ $nl { $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:" diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index 6de381b166..b69773f3b1 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -3,7 +3,8 @@ ! 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 ; IN: concurrency.messaging.tests [ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test @@ -52,4 +53,15 @@ SYMBOL: exit [ value , self , ] { } make "counter" get send receive exit "counter" get send -] unit-test \ No newline at end of file +] unit-test + +! Not yet + +! 1 "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 diff --git a/extra/io/monitors/monitors-docs.factor b/extra/io/monitors/monitors-docs.factor index 4f24879e19..ae561cd666 100755 --- a/extra/io/monitors/monitors-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -1,58 +1,106 @@ IN: io.monitors -USING: help.markup help.syntax continuations ; +USING: help.markup help.syntax continuations +concurrency.mailboxes quotations ; + +HELP: with-monitors +{ $values { "quot" quotation } } +{ $description "Calls a quotation in a new dynamic scope where file system monitor operations can be performed." } +{ $errors "Throws an error if the platform does not support file system change monitors." } ; HELP: { $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "monitor" "a new monitor" } } -{ $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." -$nl -"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." } ; +{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." } +{ $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." } ; + +HELP: (monitor) +{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "mailbox" mailbox } { "monitor" "a new monitor" } } +{ $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." } +{ $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." } ; HELP: next-change { $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } } -{ $description "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" } "." } ; +{ $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" } "." } +{ $errors "Throws an error if the monitor is closed from another thread." } ; HELP: with-monitor { $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } } -{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ; +{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } +{ $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." } ; HELP: +add-file+ -{ $description "Indicates that the file has been added to the directory." } ; +{ $description "Indicates that a file has been added to its parent directory." } ; HELP: +remove-file+ -{ $description "Indicates that the file has been removed from the directory." } ; +{ $description "Indicates that a file has been removed from its parent directory." } ; HELP: +modify-file+ -{ $description "Indicates that the file contents have changed." } ; +{ $description "Indicates that a file's contents have changed." } ; -HELP: +rename-file+ -{ $description "Indicates that file has been renamed." } ; +HELP: +rename-file-old+ +{ $description "Indicates that a file has been renamed, and this is the old name." } ; + +HELP: +rename-file-new+ +{ $description "Indicates that a file has been renamed, and this is the new name." } ; ARTICLE: "io.monitors.descriptors" "File system change descriptors" "Change descriptors output by " { $link next-change } ":" { $subsection +add-file+ } { $subsection +remove-file+ } { $subsection +modify-file+ } -{ $subsection +rename-file+ } -{ $subsection +add-file+ } ; +{ $subsection +rename-file-old+ } +{ $subsection +rename-file-new+ } ; + +ARTICLE: "io.monitors.platforms" "Monitors on different platforms" +"Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link } " is platform-specific. User code should not assume either case." +{ $heading "Mac OS X" } +"Factor uses " { $snippet "FSEventStream" } "s to implement monitors on Mac OS X. This requires Mac OS X 10.5 or later." +$nl +{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link } " has no effect." +$nl +"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." +{ $heading "Windows" } +"Factor uses " { $snippet "ReadDirectoryChanges" } " to implement monitors on Windows." +$nl +"Both recursive and non-recursive monitors are directly supported by the operating system." +{ $heading "Linux" } +"Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later." +$nl +"Since " { $snippet "inotify" } " can only monitor a single directory, Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory. This is transparent to user code." +$nl +"Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory." +{ $heading "BSD" } +"Factor uses " { $snippet "kqueue" } " to implement monitors on BSD." +$nl +"Since " { $snippet "kqueue" } " can only monitor a single directory, Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory. This is transparent to user code." +$nl +"Because " { $snippet "kqueue" } " requires that a file descriptor is allocated for each directory being monitored, monitoring of large directory hierarchies may exhaust file descriptors or exhibit suboptimal performance. Furthermore, unmounting a subdirectory of a recursively-monitored directory is not possible." +{ $heading "Windows CE" } +"Windows CE does not support monitors." ; ARTICLE: "io.monitors" "File system change monitors" "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." $nl +"Monitoring operations must be wrapped in a combinator:" +{ $subsection with-monitors } "Creating a file system change monitor and listening for changes:" { $subsection } { $subsection next-change } +"An alternative programming style is where instead of having a thread listen for changes on a monitor, change notifications are posted to a mailbox:" +{ $subsection (monitor) } { $subsection "io.monitors.descriptors" } -"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "." -$nl -"A utility combinator which opens a monitor and cleans it up after:" +{ $subsection "io.monitors.platforms" } +"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } ". An easy way to pair construction with disposal is to use a combinator:" { $subsection with-monitor } -"An example which watches the Factor directory for changes:" +"Monitors support the " { $link "io.timeouts" } "." +$nl +"An example which watches a directory for changes:" { $code "USE: io.monitors" ": watch-loop ( monitor -- )" " dup next-change . . nl nl flush watch-loop ;" "" - "\"\" resource-path f [ watch-loop ] with-monitor" + ": watch-directory ( path -- )" + " [ t [ watch-loop ] with-monitor ] with-monitors" } ; ABOUT: "io.monitors" diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index 7170e824c8..6f7478fce2 100644 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -3,36 +3,89 @@ USING: io.monitors tools.test io.files system sequences continuations namespaces concurrency.count-downs kernel io threads calendar prettyprint ; -os { winnt macosx linux } member? [ - [ "monitor-test" temp-file delete-tree ] ignore-errors +os wince? [ + [ + [ "monitor-test" temp-file delete-tree ] ignore-errors - [ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test + [ ] [ "monitor-test" temp-file make-directory ] unit-test - [ ] [ "monitor-test" temp-file t "m" set ] unit-test + [ ] [ "monitor-test" temp-file t "m" set ] unit-test - [ ] [ 1 "b" set ] unit-test + [ ] [ "monitor-test/a1" temp-file make-directory ] unit-test - [ ] [ 1 "c" set ] unit-test + [ ] [ "monitor-test/a2" temp-file make-directory ] unit-test - [ ] [ - [ - "b" get count-down - [ - "m" get next-change drop - dup print flush right-trim-separators - "xyz" tail? not - ] [ ] [ ] while - "c" get count-down - ] "Monitor test thread" spawn drop - ] unit-test + [ ] [ "monitor-test/a1" temp-file "monitor-test/a2" temp-file move-file-into ] unit-test - [ ] [ "b" get await ] unit-test + [ t ] [ "monitor-test/a2/a1" temp-file exists? ] unit-test - [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test + [ ] [ "monitor-test/a2/a1/a3.txt" temp-file touch-file ] unit-test - [ ] [ "c" get 30 seconds await-timeout ] unit-test + [ t ] [ "monitor-test/a2/a1/a3.txt" temp-file exists? ] unit-test - [ ] [ "m" get dispose ] 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 - [ "m" get dispose ] must-fail -] when + [ 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 "m" set ] unit-test + + [ ] [ 1 "b" set ] unit-test + + [ ] [ 1 "c1" set ] unit-test + + [ ] [ 1 "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 5 seconds 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 5 seconds await-timeout ] unit-test + + ! Dispose twice + [ ] [ "m" get dispose ] unit-test + + [ ] [ "m" get dispose ] unit-test + ] with-monitors +] unless diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 1678c2de41..8128acfea8 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -1,83 +1,49 @@ ! 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 ; +assocs hashtables sorting arrays threads boxes io.timeouts +accessors concurrency.mailboxes ; IN: io.monitors -array ; - -M: monitor dispose - dup check-monitor - t over set-monitor-closed? - delegate dispose ; - -! Simple monitor; used on Linux and Mac OS X. On Windows, -! monitors are full-fledged ports. -TUPLE: simple-monitor handle callback timeout ; - -M: simple-monitor timeout simple-monitor-timeout ; - -M: simple-monitor set-timeout set-simple-monitor-timeout ; - -: ( handle -- simple-monitor ) - f (monitor) { - set-simple-monitor-handle - set-delegate - set-simple-monitor-callback - } simple-monitor construct ; - -: construct-simple-monitor ( handle class -- simple-monitor ) - >r r> construct-delegate ; inline - -: notify-callback ( simple-monitor -- ) - simple-monitor-callback [ resume ] if-box? ; - -M: simple-monitor timed-out - notify-callback ; - -M: simple-monitor fill-queue ( monitor -- ) +: with-monitors ( quot -- ) [ - [ swap simple-monitor-callback >box ] - "monitor" suspend drop - ] with-timeout - check-monitor ; + init-monitors + [ dispose-monitors ] [ ] cleanup + ] with-scope ; inline -M: simple-monitor dispose ( monitor -- ) - dup delegate dispose notify-callback ; +TUPLE: monitor < identity-tuple path queue timeout ; -PRIVATE> +M: monitor hashcode* path>> hashcode* ; -HOOK: io-backend ( path recursive? -- monitor ) +M: monitor timeout timeout>> ; + +M: monitor set-timeout (>>timeout) ; + +: construct-monitor ( path mailbox class -- monitor ) + construct-empty + swap >>queue + swap >>path ; inline + +: queue-change ( path changes monitor -- ) + dup [ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ; + +HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor ) + +: ( path recursive? -- monitor ) + (monitor) ; : next-change ( monitor -- path changed ) - dup check-monitor - dup monitor-queue dup assoc-empty? [ - drop dup fill-queue next-change - ] [ nip dequeue-change ] if ; + [ queue>> ] [ timeout ] bi mailbox-get-timeout first2 ; SYMBOL: +add-file+ SYMBOL: +remove-file+ SYMBOL: +modify-file+ -SYMBOL: +rename-file+ +SYMBOL: +rename-file-old+ +SYMBOL: +rename-file-new+ : with-monitor ( path recursive? quot -- ) >r r> with-disposal ; inline diff --git a/extra/io/monitors/recursive/recursive-tests.factor b/extra/io/monitors/recursive/recursive-tests.factor new file mode 100644 index 0000000000..3182747194 --- /dev/null +++ b/extra/io/monitors/recursive/recursive-tests.factor @@ -0,0 +1,59 @@ +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 construct-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 construct-boa dummy-monitor-created set ] unit-test +[ ] [ 0 counter construct-boa dummy-monitor-disposed set ] unit-test + +[ ] [ + mock-io-backend io-backend [ + "" resource-path 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 dispose + ] with-variable +] must-fail + +[ ] [ + mock-io-backend io-backend [ + "" resource-path + [ dispose ] [ dispose ] bi + ] with-variable +] unit-test diff --git a/extra/io/monitors/recursive/recursive.factor b/extra/io/monitors/recursive/recursive.factor new file mode 100644 index 0000000000..8c2560f681 --- /dev/null +++ b/extra/io/monitors/recursive/recursive.factor @@ -0,0 +1,105 @@ +! 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 ; +IN: io.monitors.recursive + +! Simulate recursive monitors on platforms that don't have them + +TUPLE: recursive-monitor < monitor children thread ready ; + +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 yield ] each + ] curry ignore-errors ; + +: add-child-monitor ( path -- ) + qualify-path dup link-info type>> +directory+ eq? [ + [ add-child-monitors ] + [ + [ f my-mailbox (monitor) ] keep + monitor tget children>> set-at + ] bi + ] [ drop ] if ; + +USE: io +USE: prettyprint + +: 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 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 ; + +: ( path mailbox -- monitor ) + >r (normalize-path) r> + recursive-monitor construct-monitor + H{ } clone >>children + >>ready + dup start-pump-thread + dup wait-for-ready ; diff --git a/extra/io/timeouts/timeouts-docs.factor b/extra/io/timeouts/timeouts-docs.factor index df7e1389cc..64104083be 100755 --- a/extra/io/timeouts/timeouts-docs.factor +++ b/extra/io/timeouts/timeouts-docs.factor @@ -18,13 +18,13 @@ HELP: with-timeout { $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." } ; ARTICLE: "io.timeouts" "I/O timeout protocol" -"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." +"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." { $subsection timeout } { $subsection set-timeout } "The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations." { $subsection timed-out } "A combinator to be used in operations which can time out:" { $subsection with-timeout } -{ $see-also "stream-protocol" "io.launcher" } ; +{ $see-also "stream-protocol" "io.launcher" "io.monitors" } ; ABOUT: "io.timeouts" diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 30c61f6d21..e75f4c5f6b 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -1,125 +1,10 @@ ! 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 accessors system ; +USING: kernel io.backend io.monitors io.unix.backend +io.unix.select io.unix.linux.monitors system namespaces ; IN: io.unix.linux -TUPLE: linux-monitor ; - -: ( wd -- monitor ) - linux-monitor construct-simple-monitor ; - -TUPLE: inotify watches ; - -: watches ( -- assoc ) inotify get-global watches>> ; - -: wd>monitor ( wd -- monitor ) watches at ; - -: ( -- port/f ) - H{ } clone - inotify_init dup 0 < [ 2drop f ] [ - inotify - { set-inotify-watches set-delegate } inotify construct - ] if ; - -: inotify-fd inotify get-global 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 - [ 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 ( 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 -- ? ) - fill>> >= ; - -: inotify-event@ ( i buffer -- alien ) - ptr>> ; - -: 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 ; - -: ( port -- task ) - f inotify-task ; - -: init-inotify ( mx -- ) - dup [ - dup inotify set-global - swap register-io-task - ] [ - 2drop - ] if ; - -M: inotify-task do-io-task ( task -- ) - io-task-port read-notifications f ; - M: linux init-io ( -- ) - - [ mx set-global ] - [ init-inotify ] bi ; + mx set-global ; linux set-io-backend diff --git a/extra/io/unix/linux/monitors/monitors.factor b/extra/io/unix/linux/monitors/monitors.factor new file mode 100644 index 0000000000..5f23199146 --- /dev/null +++ b/extra/io/unix/linux/monitors/monitors.factor @@ -0,0 +1,129 @@ +! 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 unix.linux.inotify assocs +namespaces threads continuations init math math.bitfields +alien.c-types alien vocabs.loader accessors system ; +IN: io.unix.linux.monitors + +TUPLE: linux-monitor < monitor wd ; + +: ( wd path mailbox -- monitor ) + linux-monitor construct-monitor + swap >>wd ; + +SYMBOL: watches + +SYMBOL: inotify + +: wd>monitor ( wd -- monitor ) watches get at ; + +: ( -- port/f ) + inotify_init dup 0 < [ drop f ] [ ] 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> + [ ] [ ] [ wd>> ] tri watches get set-at ; + +: check-inotify + inotify get [ + "Calling outside with-monitors" throw + ] unless ; + +M: linux (monitor) ( path recursive? mailbox -- monitor ) + swap [ + + ] [ + check-inotify + IN_CHANGE_EVENTS swap add-watch + ] if ; + +M: linux-monitor dispose ( monitor -- ) + [ wd>> watches get delete-at ] + [ wd>> inotify-fd swap inotify_rm_watch io-error ] bi ; + +: ?flag ( n mask symbol -- n ) + pick rot bitand 0 > [ , ] [ drop ] 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 ; + +: parse-file-notify ( buffer -- path changed ) + dup inotify-event-mask ignore-flags? [ + drop f f + ] [ + [ inotify-event-name alien>char-string ] + [ inotify-event-mask parse-action ] bi + ] if ; + +: events-exhausted? ( i buffer -- ? ) + fill>> >= ; + +: inotify-event@ ( i buffer -- alien ) + ptr>> ; + +: 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 parse-file-notifications + 0 over buffer-reset + inotify-read-loop ; + +: inotify-read-thread ( port -- ) + [ inotify-read-loop ] curry ignore-errors ; + +M: linux init-monitors + H{ } clone watches set + [ + [ 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 ; diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor index c1c73ea018..039b1b250b 100644 --- a/extra/io/unix/macosx/macosx.factor +++ b/extra/io/unix/macosx/macosx.factor @@ -1,23 +1,22 @@ -USING: io.unix.bsd io.backend io.monitors io.monitors.private -continuations kernel core-foundation.fsevents sequences -namespaces arrays system ; +! 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 ; IN: io.unix.macosx macosx 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 ; -M: macosx - drop - f macosx-monitor construct-simple-monitor +M:: macosx (monitor) ( path recursive? mailbox -- monitor ) + path mailbox macosx-monitor construct-monitor dup [ enqueue-notifications ] curry - rot 1array 0 0 - over set-simple-monitor-handle ; + path 1array 0 0 >>handle ; M: macosx-monitor dispose - dup simple-monitor-handle dispose delegate dispose ; + handle>> dispose ; diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index aceee0f311..6527a87010 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -29,7 +29,6 @@ TUPLE: select-mx read-fdset write-fdset ; [ 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 @@ -45,9 +44,9 @@ TUPLE: select-mx read-fdset write-fdset ; [ 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 -- ) diff --git a/extra/tools/threads/threads.factor b/extra/tools/threads/threads.factor index 552247e2c4..060377d127 100755 --- a/extra/tools/threads/threads.factor +++ b/extra/tools/threads/threads.factor @@ -22,7 +22,7 @@ heaps.private system math math.parser ; : threads. ( -- ) standard-table-style [ [ - { "ID" "Name" "Waiting on" "Remaining sleep" } + { "ID:" "Name:" "Waiting on:" "Remaining sleep:" } [ [ write ] with-cell ] each ] with-row diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index f763a1520d..ab5e8c66b7 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -22,22 +22,29 @@ IN: tools.vocabs.monitor : path>vocab ( path -- vocab ) chop-vocab-root path>vocab-name vocab-dir>vocab-name ; -: monitor-thread ( monitor -- ) +: monitor-loop ( monitor -- ) #! On OS X, monitors give us the full path, so we chop it #! off if its there. - next-change drop path>vocab changed-vocab reset-cache ; + dup next-change drop path>vocab changed-vocab + reset-cache + monitor-loop ; + +: monitor-thread ( -- ) + [ + [ + "" resource-path t + + H{ } clone changed-vocabs set-global + vocabs [ changed-vocab ] each + + monitor-loop + ] with-monitors + ] ignore-errors ; : start-monitor-thread ( -- ) #! Silently ignore errors during monitor creation since #! monitors are not supported on all platforms. - [ - "" resource-path t [ monitor-thread t ] curry - "Vocabulary monitor" spawn-server drop - - H{ } clone changed-vocabs set-global - - vocabs [ changed-vocab ] each - ] ignore-errors ; + [ monitor-thread ] "Vocabulary monitor" spawn drop ; [ "-no-monitors" cli-args member? [ diff --git a/extra/tools/vocabs/vocabs-tests.factor b/extra/tools/vocabs/vocabs-tests.factor index ae74d516e4..04e628d080 100644 --- a/extra/tools/vocabs/vocabs-tests.factor +++ b/extra/tools/vocabs/vocabs-tests.factor @@ -4,5 +4,6 @@ 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 diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 371bbc7813..a65a8f093a 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -85,10 +85,11 @@ SYMBOL: changed-vocabs : unchanged-vocabs ( vocabs -- ) [ unchanged-vocab ] each ; +: changed-vocab? ( vocab -- ? ) + changed-vocabs get dup [ key? ] [ 2drop t ] if ; + : filter-changed ( vocabs -- vocabs' ) - changed-vocabs get [ - [ key? ] curry subset - ] when* ; + [ changed-vocab? ] subset ; SYMBOL: modified-sources SYMBOL: modified-docs @@ -96,7 +97,7 @@ SYMBOL: modified-docs : (to-refresh) ( vocab variable loaded? path -- ) dup [ swap [ - pick changed-vocabs get key? [ + pick changed-vocab? [ source-modified? [ get push ] [ 2drop ] if ] [ 3drop ] if ] [ drop get push ] if From 0c7e742b8c9796d5352b5721001245f68e9a13cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 08:35:07 -0500 Subject: [PATCH 644/886] step-into for hooks --- core/generic/standard/standard.factor | 10 ++++++++-- extra/tools/walker/walker.factor | 1 + 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index ed5134a624..98194e7ef3 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -110,6 +110,9 @@ ERROR: no-next-method class generic ; \ if , ] [ ] make ; +: single-effective-method ( obj word -- method ) + [ order [ instance? ] with find-last nip ] keep method ; + TUPLE: standard-combination # ; C: standard-combination @@ -142,8 +145,7 @@ M: standard-combination next-method-quot* ] with-standard ; M: standard-generic effective-method - [ dispatch# (picker) call ] keep - [ order [ instance? ] with find-last nip ] keep method ; + [ dispatch# (picker) call ] keep single-effective-method ; TUPLE: hook-combination var ; @@ -161,6 +163,10 @@ M: hook-combination dispatch# drop 0 ; M: hook-generic extra-values drop 1 ; +M: hook-generic effective-method + [ "combination" word-prop var>> get ] keep + single-effective-method ; + M: hook-combination make-default-method [ error-method ] with-hook ; diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index 4d1a4da6b1..42c8f93e4c 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -72,6 +72,7 @@ M: object add-breakpoint ; { { [ 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 ] } { [ t ] [ word-def (step-into-quot) ] } } cond ; From 82d793b14183ab06e597738811e6950f8848c599 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 08:35:21 -0500 Subject: [PATCH 645/886] Update Mac OS X monitors for new API --- extra/core-foundation/fsevents/fsevents.factor | 4 +--- extra/io/monitors/monitors.factor | 3 ++- extra/io/unix/macosx/macosx.factor | 17 +++++++++++------ 3 files changed, 14 insertions(+), 10 deletions(-) diff --git a/extra/core-foundation/fsevents/fsevents.factor b/extra/core-foundation/fsevents/fsevents.factor index 55f2462061..f181d8a761 100644 --- a/extra/core-foundation/fsevents/fsevents.factor +++ b/extra/core-foundation/fsevents/fsevents.factor @@ -151,12 +151,10 @@ SYMBOL: event-stream-callbacks [ event-stream-callbacks global - [ [ drop expired? not ] assoc-subset ] change-at + [ [ drop expired? not ] assoc-subset H{ } assoc-like ] change-at 1 \ event-stream-counter set-global ] "core-foundation" add-init-hook -event-stream-callbacks global [ H{ } assoc-like ] change-at - : add-event-source-callback ( quot -- id ) event-stream-counter [ event-stream-callbacks get set-at ] keep ; diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 8128acfea8..8d2ddba5f2 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -29,7 +29,8 @@ M: monitor set-timeout (>>timeout) ; swap >>path ; inline : queue-change ( path changes monitor -- ) - dup [ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ; + 3dup and and + [ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ; HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor ) diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor index 039b1b250b..68eb2f13bb 100644 --- a/extra/io/unix/macosx/macosx.factor +++ b/extra/io/unix/macosx/macosx.factor @@ -1,17 +1,20 @@ ! 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 ; +continuations kernel sequences namespaces arrays system locals +accessors ; IN: io.unix.macosx -macosx set-io-backend - 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 init-monitors ; + +M: macosx dispose-monitors ; M:: macosx (monitor) ( path recursive? mailbox -- monitor ) path mailbox macosx-monitor construct-monitor @@ -20,3 +23,5 @@ M:: macosx (monitor) ( path recursive? mailbox -- monitor ) M: macosx-monitor dispose handle>> dispose ; + +macosx set-io-backend From d132bce5a3603eb9df65f390cce6301c5903adff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 09:54:50 -0500 Subject: [PATCH 646/886] Implement monitors for BSD --- extra/io/monitors/monitors-docs.factor | 6 +- extra/io/monitors/monitors-tests.factor | 4 +- extra/io/monitors/monitors.factor | 1 + extra/io/unix/backend/backend.factor | 3 + extra/io/unix/bsd/bsd.factor | 19 +++- extra/io/unix/kqueue/kqueue.factor | 104 +++++++++++++++---- extra/io/unix/linux/monitors/monitors.factor | 5 +- 7 files changed, 113 insertions(+), 29 deletions(-) mode change 100755 => 100644 extra/io/unix/backend/backend.factor mode change 100755 => 100644 extra/io/unix/kqueue/kqueue.factor diff --git a/extra/io/monitors/monitors-docs.factor b/extra/io/monitors/monitors-docs.factor index ae561cd666..df4f7ae352 100755 --- a/extra/io/monitors/monitors-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -42,13 +42,17 @@ HELP: +rename-file-old+ HELP: +rename-file-new+ { $description "Indicates that a file has been renamed, and this is the new name." } ; +HELP: +rename-file+ +{ $description "Indicates that a file has been renamed." } ; + ARTICLE: "io.monitors.descriptors" "File system change descriptors" "Change descriptors output by " { $link next-change } ":" { $subsection +add-file+ } { $subsection +remove-file+ } { $subsection +modify-file+ } { $subsection +rename-file-old+ } -{ $subsection +rename-file-new+ } ; +{ $subsection +rename-file-new+ } +{ $subsection +rename-file+ } ; ARTICLE: "io.monitors.platforms" "Monitors on different platforms" "Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link } " is platform-specific. User code should not assume either case." diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index 6f7478fce2..0216baf699 100644 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -3,7 +3,7 @@ USING: io.monitors tools.test io.files system sequences continuations namespaces concurrency.count-downs kernel io threads calendar prettyprint ; -os wince? [ +os { winnt linux macosx } member? [ [ [ "monitor-test" temp-file delete-tree ] ignore-errors @@ -88,4 +88,4 @@ os wince? [ [ ] [ "m" get dispose ] unit-test ] with-monitors -] unless +] when diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 8d2ddba5f2..51cbdd5b1b 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -45,6 +45,7 @@ SYMBOL: +remove-file+ SYMBOL: +modify-file+ SYMBOL: +rename-file-old+ SYMBOL: +rename-file-new+ +SYMBOL: +rename-file+ : with-monitor ( path recursive? quot -- ) >r r> with-disposal ; inline diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor old mode 100755 new mode 100644 index 865490b0ce..0fb8b0c5f2 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -203,3 +203,6 @@ M: mx-task do-io-task : multiplexer-error ( n -- ) 0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ; + +: ?flag ( n mask symbol -- n ) + pick rot bitand 0 > [ , ] [ drop ] if ; diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index 12a64a41f9..03723a65e5 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -1,8 +1,21 @@ ! 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.select -namespaces system ; +USING: namespaces system kernel accessors assocs continuations +unix +io.backend io.unix.backend io.unix.select io.unix.kqueue io.monitors ; M: bsd init-io ( -- ) - mx set-global ; + mx set-global + kqueue-mx set-global + kqueue-mx get-global + dup io-task-fd + [ mx get-global reads>> set-at ] + [ mx get-global writes>> set-at ] 2bi ; + +M: bsd init-monitors ; + +M: bsd dispose-monitors ; + +M: bsd (monitor) ( path recursive? mailbox -- ) + nip ; diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor old mode 100755 new mode 100644 index 97b186edf3..3735caa7d2 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -1,12 +1,14 @@ ! 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 +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 events monitors ; : max-events ( -- n ) #! We read up to 256 events at a time. This is an arbitrary @@ -15,8 +17,9 @@ TUPLE: kqueue-mx events ; : ( -- mx ) kqueue-mx construct-mx - kqueue dup io-error over set-mx-fd - max-events "kevent" over set-kqueue-mx-events ; + H{ } clone >>monitors + kqueue dup io-error >>fd + max-events "kevent" >>events ; GENERIC: io-task-filter ( task -- n ) @@ -24,14 +27,19 @@ M: input-task io-task-filter drop EVFILT_READ ; 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" 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 -- ) @@ -43,33 +51,52 @@ M: kqueue-mx unregister-io-task ( task mx -- ) swap EV_DELETE make-kevent swap register-kevent ; : 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" tuck set-kevent-ident @@ -77,5 +104,44 @@ M: kqueue-mx wait-for-events ( ms mx -- ) 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" + 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 ; + +: ( path mailbox -- monitor ) + >r [ O_RDONLY 0 open dup io-error ] keep r> + vnode-monitor construct-monitor swap >>fd + [ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ; + +M: vnode-monitor dispose + [ kqueue-mx get unregister-monitor ] [ fd>> close ] bi ; diff --git a/extra/io/unix/linux/monitors/monitors.factor b/extra/io/unix/linux/monitors/monitors.factor index 5f23199146..a257873ed5 100644 --- a/extra/io/unix/linux/monitors/monitors.factor +++ b/extra/io/unix/linux/monitors/monitors.factor @@ -55,9 +55,6 @@ M: linux-monitor dispose ( monitor -- ) [ wd>> watches get delete-at ] [ wd>> inotify-fd swap inotify_rm_watch io-error ] bi ; -: ?flag ( n mask symbol -- n ) - pick rot bitand 0 > [ , ] [ drop ] if ; - : ignore-flags? ( mask -- ? ) { IN_DELETE_SELF @@ -76,7 +73,7 @@ M: linux-monitor dispose ( monitor -- ) IN_MOVED_FROM +rename-file-old+ ?flag IN_MOVED_TO +rename-file-new+ ?flag drop - ] { } make ; + ] { } make prune ; : parse-file-notify ( buffer -- path changed ) dup inotify-event-mask ignore-flags? [ From 1f759a7b2d6377ae6227445fcb1e15dae9b4a768 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 10:09:45 -0500 Subject: [PATCH 647/886] Fix documentation --- extra/io/monitors/monitors-docs.factor | 6 ++---- extra/io/unix/bsd/bsd.factor | 3 ++- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/extra/io/monitors/monitors-docs.factor b/extra/io/monitors/monitors-docs.factor index df4f7ae352..cd6a06a8e9 100755 --- a/extra/io/monitors/monitors-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -69,15 +69,13 @@ $nl { $heading "Linux" } "Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later." $nl -"Since " { $snippet "inotify" } " can only monitor a single directory, Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory. This is transparent to user code." +"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." $nl "Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory." { $heading "BSD" } "Factor uses " { $snippet "kqueue" } " to implement monitors on BSD." $nl -"Since " { $snippet "kqueue" } " can only monitor a single directory, Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory. This is transparent to user code." -$nl -"Because " { $snippet "kqueue" } " requires that a file descriptor is allocated for each directory being monitored, monitoring of large directory hierarchies may exhaust file descriptors or exhibit suboptimal performance. Furthermore, unmounting a subdirectory of a recursively-monitored directory is not possible." +"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." { $heading "Windows CE" } "Windows CE does not support monitors." ; diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index 03723a65e5..1b51b3c4e4 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -18,4 +18,5 @@ M: bsd init-monitors ; M: bsd dispose-monitors ; M: bsd (monitor) ( path recursive? mailbox -- ) - nip ; + swap [ "Recursive kqueue monitors not supported" throw ] when + ; From 8460780f61906a7d39df01df785741d7c0863f58 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 12:18:39 -0500 Subject: [PATCH 648/886] Do a runloop so that monitors work in terminal --- extra/cocoa/application/application.factor | 9 +++--- extra/core-foundation/core-foundation.factor | 2 +- .../core-foundation/fsevents/fsevents.factor | 23 +++++++++----- .../core-foundation/run-loop/run-loop.factor | 30 +++++++++++++++++++ extra/io/monitors/monitors-tests.factor | 4 +-- 5 files changed, 52 insertions(+), 16 deletions(-) create mode 100644 extra/core-foundation/run-loop/run-loop.factor diff --git a/extra/cocoa/application/application.factor b/extra/cocoa/application/application.factor index 0cf020a087..129b949b1d 100755 --- a/extra/cocoa/application/application.factor +++ b/extra/cocoa/application/application.factor @@ -1,8 +1,9 @@ ! 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 : ( str -- alien ) -> autorelease ; @@ -21,8 +22,6 @@ IN: cocoa.application : with-cocoa ( quot -- ) [ NSApp drop call ] with-autorelease-pool ; -: CFRunLoopDefaultMode "kCFRunLoopDefaultMode" ; - : next-event ( app -- event ) 0 f CFRunLoopDefaultMode 1 -> nextEventMatchingMask:untilDate:inMode:dequeue: ; diff --git a/extra/core-foundation/core-foundation.factor b/extra/core-foundation/core-foundation.factor index 73b8fce229..5025ab39a7 100644 --- a/extra/core-foundation/core-foundation.factor +++ b/extra/core-foundation/core-foundation.factor @@ -9,9 +9,9 @@ TYPEDEF: void* CFBundleRef 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 diff --git a/extra/core-foundation/fsevents/fsevents.factor b/extra/core-foundation/fsevents/fsevents.factor index f181d8a761..24211a59c7 100644 --- a/extra/core-foundation/fsevents/fsevents.factor +++ b/extra/core-foundation/fsevents/fsevents.factor @@ -1,7 +1,8 @@ ! 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 ; +namespaces assocs init accessors continuations combinators +core-foundation core-foundation.run-loop ; IN: core-foundation.fsevents ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! @@ -182,11 +183,11 @@ SYMBOL: event-stream-callbacks } "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 ; : ( quot paths latency flags -- event-stream ) >r >r >r @@ -194,9 +195,15 @@ TUPLE: event-stream info handle ; >r master-event-source-callback r> r> r> r> dup enable-event-stream - event-stream construct-boa ; + f event-stream construct-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 ; diff --git a/extra/core-foundation/run-loop/run-loop.factor b/extra/core-foundation/run-loop/run-loop.factor new file mode 100644 index 0000000000..7cd148e022 --- /dev/null +++ b/extra/core-foundation/run-loop/run-loop.factor @@ -0,0 +1,30 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel threads init +cocoa.application core-foundation ; +IN: core-foundation.run-loop + +: kCFRunLoopRunFinished 1 ; inline +: kCFRunLoopRunStopped 2 ; inline +: kCFRunLoopRunTimedOut 3 ; inline +: kCFRunLoopRunHandledSource 4 ; inline + +TYPEDEF: void* CFRunLoopRef + +FUNCTION: SInt32 CFRunLoopRunInMode ( + CFStringRef mode, + CFTimeInterval seconds, + Boolean returnAfterSourceHandled +) ; + +: CFRunLoopDefaultMode "kCFRunLoopDefaultMode" ; + +: 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 diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index 0216baf699..ab919dd008 100644 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -75,13 +75,13 @@ os { winnt linux macosx } member? [ [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test - [ ] [ "c1" get 5 seconds await-timeout ] unit-test + [ ] [ "c1" get 15 seconds 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 5 seconds await-timeout ] unit-test + [ ] [ "c2" get 15 seconds await-timeout ] unit-test ! Dispose twice [ ] [ "m" get dispose ] unit-test From c5de8189259991d11bbec37bce6be5882784e7ae Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 12:47:49 -0500 Subject: [PATCH 649/886] Use inheritance in Unix I?O backend --- extra/io/unix/backend/backend.factor | 32 ++++++++++++---------------- extra/io/unix/epoll/epoll.factor | 8 +++---- extra/io/unix/kqueue/kqueue.factor | 12 ++++++----- extra/io/unix/select/select.factor | 6 +++--- extra/io/unix/sockets/sockets.factor | 16 +++++++------- 5 files changed, 35 insertions(+), 39 deletions(-) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 0fb8b0c5f2..d42f8827b1 100644 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -14,18 +14,13 @@ TUPLE: io-task port callbacks ; : io-task-fd port>> handle>> ; : ( port continuation/f class -- task ) - >r [ 1vector ] [ V{ } clone ] if* io-task construct-boa - r> construct-delegate ; inline + construct-empty + swap [ 1vector ] [ V{ } clone ] if* >>callbacks + swap >>port ; inline -TUPLE: input-task ; +TUPLE: input-task < io-task ; -: ( port continuation class -- task ) - >r input-task r> construct-delegate ; inline - -TUPLE: output-task ; - -: ( port continuation class -- task ) - >r output-task r> construct-delegate ; inline +TUPLE: output-task < io-task ; GENERIC: do-io-task ( task -- ? ) GENERIC: io-task-container ( mx task -- hashtable ) @@ -37,9 +32,10 @@ M: input-task io-task-container drop reads>> ; M: output-task io-task-container drop writes>> ; -: ( -- mx ) f H{ } clone H{ } clone mx construct-boa ; - -: construct-mx ( class -- obj ) swap construct-delegate ; +: construct-mx ( class -- obj ) + construct-empty + H{ } clone >>reads + H{ } clone >>writes ; inline GENERIC: register-io-task ( task mx -- ) GENERIC: unregister-io-task ( task mx -- ) @@ -140,10 +136,10 @@ M: unix cancel-io ( port -- ) drop t ] if ; -TUPLE: read-task ; +TUPLE: read-task < input-task ; : ( port continuation -- task ) - read-task ; + read-task ; M: read-task do-io-task io-task-port dup refill @@ -158,10 +154,10 @@ M: input-port (wait-to-read) dup [ handle>> ] [ buffer@ ] [ buffer-length ] tri write dup 0 >= [ swap buffer-consume f ] [ drop defer-error ] if ; -TUPLE: write-task ; +TUPLE: write-task < output-task ; : ( port continuation -- task ) - write-task ; + write-task ; M: write-task do-io-task io-task-port dup [ buffer-empty? ] [ port-error ] bi or @@ -193,7 +189,7 @@ TUPLE: mx-port mx ; dup fd>> f mx-port { set-mx-port-mx set-delegate } mx-port construct ; -TUPLE: mx-task ; +TUPLE: mx-task < io-task ; : ( port -- task ) f mx-task ; diff --git a/extra/io/unix/epoll/epoll.factor b/extra/io/unix/epoll/epoll.factor index 1459549f9e..2d7ca9ba3f 100644 --- a/extra/io/unix/epoll/epoll.factor +++ b/extra/io/unix/epoll/epoll.factor @@ -5,7 +5,7 @@ bit-arrays sequences assocs unix unix.linux.epoll math 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 @@ -33,12 +33,10 @@ M: output-task io-task-events drop EPOLLOUT ; 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 diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index 3735caa7d2..3a140bdbec 100644 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -8,7 +8,7 @@ io.nonblocking io.unix.backend io.launcher io.unix.launcher io.monitors ; IN: io.unix.kqueue -TUPLE: kqueue-mx events monitors ; +TUPLE: kqueue-mx < mx events monitors ; : max-events ( -- n ) #! We read up to 256 events at a time. This is an arbitrary @@ -43,12 +43,14 @@ M: io-task io-task-fflags drop 0 ; 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 [ fd>> f 0 ] keep events>> max-events r> kevent diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index 6527a87010..facaf4d73d 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -5,7 +5,7 @@ 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 @@ -15,8 +15,8 @@ TUPLE: select-mx read-fdset write-fdset ; : ( -- mx ) select-mx construct-mx - FD_SETSIZE 8 * >>read-fdset - FD_SETSIZE 8 * >>write-fdset ; + FD_SETSIZE 8 * >>read-fdset + FD_SETSIZE 8 * >>write-fdset ; : clear-nth ( n seq -- ? ) [ nth ] [ f -rot set-nth ] 2bi ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index a54205a878..9ad1338b96 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -30,10 +30,10 @@ M: unix addrinfo-error ( n -- ) : init-client-socket ( fd -- ) SOL_SOCKET SO_OOBINLINE sockopt ; -TUPLE: connect-task ; +TUPLE: connect-task < output-task ; : ( port continuation -- task ) - connect-task ; + connect-task ; M: connect-task do-io-task io-task-port dup port-handle f 0 write @@ -61,10 +61,10 @@ USE: unix : init-server-socket ( fd -- ) SOL_SOCKET SO_REUSEADDR sockopt ; -TUPLE: accept-task ; +TUPLE: accept-task < input-task ; : ( port continuation -- task ) - accept-task ; + accept-task ; : accept-sockaddr ( port -- fd sockaddr ) dup port-handle swap server-port-addr sockaddr-type @@ -128,10 +128,10 @@ packet-size receive-buffer set-global rot head ] if ; -TUPLE: receive-task ; +TUPLE: receive-task < input-task ; : ( stream continuation -- task ) - receive-task ; + receive-task ; M: receive-task do-io-task io-task-port @@ -157,10 +157,10 @@ M: unix receive ( datagram -- packet addrspec ) : 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 ; : ( packet sockaddr len stream continuation -- task ) - send-task [ + send-task [ { set-send-task-packet set-send-task-sockaddr From ce57aca4f541b9236e2aad46af8ca7eb235d9e08 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 11 Apr 2008 12:51:50 -0500 Subject: [PATCH 650/886] case now executes its keys if they are words cond now accepts a default quotation --- core/combinators/combinators-docs.factor | 10 +- core/combinators/combinators-tests.factor | 232 +++++++++++++++++++++- core/combinators/combinators.factor | 30 ++- 3 files changed, 254 insertions(+), 18 deletions(-) diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index f497fd20e5..54c62c44fa 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -64,9 +64,9 @@ HELP: alist>quot { $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" } @@ -78,7 +78,7 @@ HELP: cond "{" " { [ dup 0 > ] [ \"positive\" ] }" " { [ dup 0 < ] [ \"negative\" ] }" - " { [ dup zero? ] [ \"zero\" ] }" + " [ \"zero\" ]" "} cond" } } ; @@ -88,9 +88,9 @@ HELP: no-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 diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 8abc53e43f..b612669b71 100755 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -1,7 +1,54 @@ -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" ] } @@ -21,11 +68,66 @@ namespaces combinators words ; { [ dup string? ] [ drop "string" ] } { [ dup float? ] [ drop "float" ] } { [ dup alien? ] [ drop "alien" ] } - { [ t ] [ drop "neither" ] } + [ drop "neither" ] } cond ] unit-test -: case-test-1 +[ "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 + +[ "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" ] } @@ -33,6 +135,8 @@ namespaces combinators words ; { 4 [ "four" ] } } case ; +\ case-test-1 must-infer + [ "two" ] [ 2 case-test-1 ] unit-test ! Interpreted @@ -40,7 +144,7 @@ namespaces combinators words ; [ "x" case-test-1 ] must-fail -: case-test-2 +: case-test-2 ( obj -- obj' ) { { 1 [ "one" ] } { 2 [ "two" ] } @@ -49,12 +153,14 @@ namespaces combinators words ; [ 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" ] } @@ -65,8 +171,122 @@ namespaces combinators words ; [ 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 diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 96c4009ba9..11ad8d60e7 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -3,7 +3,7 @@ IN: combinators USING: arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors -hashtables sorting ; +hashtables sorting words ; : cleave ( x seq -- ) [ call ] with each ; @@ -34,13 +34,24 @@ hashtables sorting ; ERROR: no-cond ; : cond ( assoc -- ) - [ first call ] find nip dup [ second call ] [ no-cond ] if ; + [ dup callable? [ drop t ] [ first call ] if ] find nip + [ dup callable? [ call ] [ second call ] if ] + [ no-cond ] if* ; 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 ] } @@ -73,11 +84,14 @@ M: hashtable hashcode* [ 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 prefix ] assoc-map - alist>quot ; + [ + [ 1quotation \ dup prefix \ = suffix ] + [ \ drop prefix ] bi* + ] assoc-map alist>quot ; : (distribute-buckets) ( buckets pair keys -- ) dup t eq? [ @@ -135,7 +149,9 @@ M: hashtable hashcode* dup empty? [ drop ] [ - dup length 4 <= [ + dup length 4 <= + over keys [ word? ] contains? or + [ linear-case-quot ] [ dup keys contiguous-range? [ From 9348b9b8a7d09d6fa0120e6f5367d5fe59491fc5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 11 Apr 2008 12:52:56 -0500 Subject: [PATCH 651/886] gensyms don't output a number in the name now --- core/words/words.factor | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/core/words/words.factor b/core/words/words.factor index 7794a7f41f..e1d2f11356 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -2,8 +2,7 @@ ! 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 ; @@ -66,11 +65,11 @@ SYMBOL: bootstrapping? GENERIC: crossref? ( word -- ? ) M: word crossref? - { - { [ dup "forgotten" word-prop ] [ f ] } - { [ dup word-vocabulary ] [ t ] } - { [ t ] [ f ] } - } cond nip ; + dup "forgotten" word-prop [ + drop f + ] [ + word-vocabulary >boolean + ] if ; GENERIC# (quot-uses) 1 ( obj assoc -- ) @@ -191,7 +190,7 @@ M: word subwords drop f ; { "methods" "combination" "default-method" } reset-props ; : gensym ( -- word ) - "G:" \ gensym counter number>string append f ; + "( gensym )" f ; : define-temp ( quot -- word ) gensym dup rot define ; From bced4022e59438846e7c362d445884e895a7bc46 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 11 Apr 2008 12:53:22 -0500 Subject: [PATCH 652/886] updating usages of cond/case --- core/alien/alien-docs.factor | 2 +- core/alien/compiler/compiler.factor | 4 +-- core/alien/syntax/syntax.factor | 2 +- core/classes/algebra/algebra.factor | 14 +++++----- core/classes/mixin/mixin.factor | 2 +- core/compiler/tests/simple.factor | 4 +-- core/cpu/x86/32/32.factor | 3 +-- core/cpu/x86/assembler/assembler.factor | 2 +- core/debugger/debugger.factor | 2 +- core/dlists/dlists.factor | 2 +- core/effects/effects.factor | 2 +- core/generator/fixup/fixup.factor | 4 +-- core/generator/generator.factor | 2 +- core/generator/registers/registers.factor | 6 ++--- core/generic/math/math.factor | 2 +- .../engines/predicate/predicate.factor | 2 +- core/inference/backend/backend.factor | 4 +-- core/io/encodings/utf8/utf8.factor | 6 ++--- core/io/files/files.factor | 27 ++++++++++--------- core/math/intervals/intervals.factor | 6 ++--- core/math/parser/parser.factor | 10 +++---- core/optimizer/control/control-tests.factor | 14 +++++----- core/optimizer/control/control.factor | 2 +- core/optimizer/inlining/inlining.factor | 8 +++--- .../pattern-match/pattern-match.factor | 2 +- .../specializers/specializers.factor | 2 +- core/parser/parser.factor | 2 +- core/prettyprint/prettyprint.factor | 2 +- core/syntax/syntax.factor | 2 +- core/threads/threads.factor | 2 +- 30 files changed, 71 insertions(+), 73 deletions(-) diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 136af91bb2..7d13080e3c 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -78,7 +78,7 @@ $nl "<< \"freetype\" {" " { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }" " { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }" - " { [ t ] [ drop ] }" + " [ drop ]" "} cond >>" } "Note the parse time evaluation with " { $link POSTPONE: << } "." } ; diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 0f74f52d60..594c42268c 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -375,7 +375,7 @@ TUPLE: callback-context ; return>> { { [ dup "void" = ] [ drop [ ] ] } { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] } - { [ t ] [ c-type c-type-prep ] } + [ c-type c-type-prep ] } cond ; : wrap-callback-quot ( node -- quot ) @@ -390,7 +390,7 @@ TUPLE: callback-context ; { { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] } { [ dup return>> large-struct? ] [ drop 4 ] } - { [ t ] [ drop 0 ] } + [ drop 0 ] } cond ; : %callback-return ( node -- ) diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index 6e4b8b4e21..67ea30f379 100755 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -68,7 +68,7 @@ M: alien pprint* { { [ 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 ; diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 4614e4c4ce..faf57fcd0d 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -84,7 +84,7 @@ C: anonymous-complement { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } { [ dup members ] [ right-union-class< ] } { [ over superclass ] [ superclass< ] } - { [ t ] [ 2drop f ] } + [ 2drop f ] } cond ; : anonymous-union-intersect? ( first second -- ? ) @@ -104,14 +104,14 @@ C: anonymous-complement { [ over tuple eq? ] [ 2drop t ] } { [ over builtin-class? ] [ 2drop f ] } { [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] } - { [ t ] [ swap classes-intersect? ] } + [ swap classes-intersect? ] } cond ; : builtin-class-intersect? ( first second -- ? ) { { [ 2dup eq? ] [ 2drop t ] } { [ over builtin-class? ] [ 2drop f ] } - { [ t ] [ swap classes-intersect? ] } + [ swap classes-intersect? ] } cond ; : (classes-intersect?) ( first second -- ? ) @@ -154,7 +154,7 @@ C: anonymous-complement { [ over members ] [ left-union-and ] } { [ over anonymous-union? ] [ left-anonymous-union-and ] } { [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] } - { [ t ] [ 2array ] } + [ 2array ] } cond ; : left-anonymous-union-or ( first second -- class ) @@ -169,7 +169,7 @@ C: anonymous-complement { [ 2dup swap class< ] [ drop ] } { [ dup anonymous-union? ] [ right-anonymous-union-or ] } { [ over anonymous-union? ] [ left-anonymous-union-or ] } - { [ t ] [ 2array ] } + [ 2array ] } cond ; : (class-not) ( class -- complement ) @@ -177,7 +177,7 @@ C: anonymous-complement { [ dup anonymous-complement? ] [ class>> ] } { [ dup object eq? ] [ drop null ] } { [ dup null eq? ] [ drop object ] } - { [ t ] [ ] } + [ ] } cond ; : largest-class ( seq -- n elt ) @@ -205,7 +205,7 @@ C: anonymous-complement { [ dup builtin-class? ] [ dup set ] } { [ dup members ] [ members [ (flatten-class) ] each ] } { [ dup superclass ] [ superclass (flatten-class) ] } - { [ t ] [ drop ] } + [ drop ] } cond ; : flatten-class ( class -- assoc ) diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index aefd522269..9bbe89d7d9 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -49,7 +49,7 @@ M: mixin-instance equal? { [ over mixin-instance? not ] [ f ] } { [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] } { [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] } - { [ t ] [ t ] } + [ t ] } cond 2nip ; M: mixin-instance hashcode* diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index 09b0c190e6..dce2ec562a 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -187,7 +187,7 @@ DEFER: countdown-b { [ dup string? ] [ drop "string" ] } { [ dup float? ] [ drop "float" ] } { [ dup alien? ] [ drop "alien" ] } - { [ t ] [ drop "neither" ] } + [ drop "neither" ] } cond ] compile-call ] unit-test @@ -196,7 +196,7 @@ DEFER: countdown-b [ 3 { { [ dup fixnum? ] [ ] } - { [ t ] [ drop t ] } + [ drop t ] } cond ] compile-call ] unit-test diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 699670aecd..cc3fceff23 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -246,9 +246,8 @@ M: x86.32 %cleanup ( alien-node -- ) } { [ dup return>> large-struct? ] [ drop EAX PUSH ] - } { - [ t ] [ drop ] } + [ drop ] } cond ; M: x86.32 %unwind ( n -- ) %epilogue-later RET ; diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index a3ab256ea1..450aa8f980 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -189,7 +189,7 @@ UNION: operand register indirect ; { { [ dup register-128? ] [ drop operand-64? ] } { [ dup not ] [ drop operand-64? ] } - { [ t ] [ nip operand-64? ] } + [ nip operand-64? ] } cond and ; : rex.r diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 071535a01e..dea1904e92 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -160,7 +160,7 @@ 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 diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index 56134f3b54..b4ae207455 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -126,7 +126,7 @@ PRIVATE> { { [ over front>> over eq? ] [ drop pop-front* ] } { [ over back>> over eq? ] [ drop pop-back* ] } - { [ t ] [ unlink-node dec-length ] } + [ unlink-node dec-length ] } cond ; : delete-node-if* ( dlist quot -- obj/f ? ) diff --git a/core/effects/effects.factor b/core/effects/effects.factor index aed4a64c6c..7da290992c 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -20,7 +20,7 @@ TUPLE: effect in out terminated? ; { [ dup effect-terminated? ] [ f ] } { [ 2dup [ effect-in length ] bi@ > ] [ f ] } { [ 2dup [ effect-height ] bi@ = not ] [ f ] } - { [ t ] [ t ] } + [ t ] } cond 2nip ; GENERIC: (stack-picture) ( obj -- str ) diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 5cc0442464..3a5a6571b7 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -40,8 +40,8 @@ M: label fixup* 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 diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 3514947e3d..7858205384 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -16,7 +16,7 @@ SYMBOL: compiled { [ 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 -- ) diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index f3dc0fb10e..8abd1cd3e0 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -195,7 +195,7 @@ INSTANCE: constant value { [ 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 -- ) @@ -357,14 +357,14 @@ SYMBOL: fresh-objects { [ 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 ) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index fce908bdef..884ab8027e 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -19,7 +19,7 @@ PREDICATE: math-class < class { { [ dup null class< ] [ drop { -1 -1 } ] } { [ dup math-class? ] [ class-types last/first ] } - { [ t ] [ drop { 100 100 } ] } + [ drop { 100 100 } ] } cond ; : math-class-max ( class class -- class ) diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor index ce7d5c6c21..5335074dea 100644 --- a/core/generic/standard/engines/predicate/predicate.factor +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -18,7 +18,7 @@ C: predicate-dispatch-engine { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } { [ dup length 1 = ] [ first second { } ] } { [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] } - { [ t ] [ [ first second ] [ 1 tail-slice ] bi ] } + [ [ first second ] [ 1 tail-slice ] bi ] } cond ; : sort-methods ( assoc -- assoc' ) diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 3dcb1d2360..1945ed1a38 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -251,7 +251,7 @@ TUPLE: cannot-unify-specials ; { [ dup [ curried? ] all? ] [ unify-curries ] } { [ dup [ composed? ] all? ] [ unify-composed ] } { [ dup [ special? ] contains? ] [ cannot-unify-specials ] } - { [ t ] [ drop ] } + [ drop ] } cond ; : unify-stacks ( seq -- stack ) @@ -395,7 +395,7 @@ TUPLE: effect-error word effect ; { [ 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 ; diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index e98860f25d..7a22107f19 100644 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -33,7 +33,7 @@ TUPLE: utf8 ; { [ dup -5 shift BIN: 110 number= ] [ double ] } { [ dup -4 shift BIN: 1110 number= ] [ triple ] } { [ dup -3 shift BIN: 11110 number= ] [ quad ] } - { [ t ] [ drop replacement-char ] } + [ drop replacement-char ] } cond ; : decode-utf8 ( stream -- char/f ) @@ -59,12 +59,12 @@ M: utf8 decode-char 2dup -6 shift encoded encoded ] } - { [ t ] [ + [ 2dup -18 shift BIN: 11110000 bitor swap stream-write1 2dup -12 shift encoded 2dup -6 shift encoded encoded - ] } + ] } cond ; M: utf8 encode-char diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 6719d1334c..061e6386da 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -95,7 +95,7 @@ ERROR: no-parent-directory path ; 1 tail left-trim-separators append-path-empty ] } { [ dup head..? ] [ drop no-parent-directory ] } - { [ t ] [ nip ] } + [ nip ] } cond ; PRIVATE> @@ -105,7 +105,7 @@ PRIVATE> { [ dup "\\\\?\\" head? ] [ t ] } { [ dup length 2 < ] [ f ] } { [ dup second CHAR: : = ] [ t ] } - { [ t ] [ f ] } + [ f ] } cond ; : absolute-path? ( path -- ? ) @@ -114,7 +114,7 @@ PRIVATE> { [ dup "resource:" head? ] [ t ] } { [ os windows? ] [ windows-absolute-path? ] } { [ dup first path-separator? ] [ t ] } - { [ t ] [ f ] } + [ f ] } cond nip ; : append-path ( str1 str2 -- str ) @@ -130,10 +130,10 @@ PRIVATE> { [ over absolute-path? over first path-separator? and ] [ >r 2 head r> append ] } - { [ t ] [ + [ >r right-trim-separators "/" r> left-trim-separators 3append - ] } + ] } cond ; : prepend-path ( str1 str2 -- str ) @@ -220,10 +220,10 @@ HOOK: make-directory io-backend ( path -- ) { [ dup root-directory? ] [ ] } { [ dup empty? ] [ ] } { [ dup exists? ] [ ] } - { [ t ] [ + [ dup parent-directory make-directories dup make-directory - ] } + ] } cond drop ; ! Directory listings @@ -322,9 +322,10 @@ C: pathname M: pathname <=> [ pathname-string ] compare ; ! Home directory -: home ( -- dir ) - { - { [ os winnt? ] [ "USERPROFILE" os-env ] } - { [ os wince? ] [ "" resource-path ] } - { [ os unix? ] [ "HOME" os-env ] } - } cond ; +HOOK: home os ( -- dir ) + +M: winnt home "USERPROFILE" os-env ; + +M: wince home "" resource-path ; + +M: unix home "HOME" os-env ; diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index cc51060f63..4ca1a8637c 100755 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -103,7 +103,7 @@ C: interval 2drop over second over second and [ ] [ 2drop f ] if ] } - { [ t ] [ 2drop ] } + [ 2drop ] } cond ; : interval-intersect ( i1 i2 -- i3 ) @@ -202,7 +202,7 @@ SYMBOL: incomparable { [ 2dup interval-intersect not ] [ (interval<) ] } { [ 2dup left-endpoint-< ] [ f ] } { [ 2dup right-endpoint-< ] [ f ] } - { [ t ] [ incomparable ] } + [ incomparable ] } cond 2nip ; : left-endpoint-<= ( i1 i2 -- ? ) @@ -215,7 +215,7 @@ SYMBOL: incomparable { { [ 2dup interval-intersect not ] [ (interval<) ] } { [ 2dup right-endpoint-<= ] [ t ] } - { [ t ] [ incomparable ] } + [ incomparable ] } cond 2nip ; : interval> ( i1 i2 -- ? ) diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 68c4768c87..1a1a080564 100755 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -62,7 +62,7 @@ SYMBOL: negative? { { [ dup empty? ] [ drop f ] } { [ f over memq? ] [ drop f ] } - { [ t ] [ radix get [ < ] curry all? ] } + [ radix get [ < ] curry all? ] } cond ; : string>integer ( str -- n/f ) @@ -77,7 +77,7 @@ PRIVATE> { { [ CHAR: / over member? ] [ string>ratio ] } { [ CHAR: . over member? ] [ string>float ] } - { [ t ] [ string>integer ] } + [ string>integer ] } cond r> [ dup [ neg ] when ] when ] with-radix ; @@ -134,10 +134,8 @@ M: ratio >base } { [ CHAR: . over member? ] [ ] - } { - [ t ] - [ ".0" append ] } + [ ".0" append ] } cond ; M: float >base @@ -145,7 +143,7 @@ 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 ; diff --git a/core/optimizer/control/control-tests.factor b/core/optimizer/control/control-tests.factor index d7638fa66d..ce77cdd43a 100755 --- a/core/optimizer/control/control-tests.factor +++ b/core/optimizer/control/control-tests.factor @@ -9,23 +9,23 @@ optimizer ; { [ 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 label-is-loop? diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index 11228c879a..f9f8901c41 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -156,7 +156,7 @@ SYMBOL: potential-loops { [ dup null class< ] [ drop f f ] } { [ dup \ f class-not class< ] [ drop t t ] } { [ dup \ f class< ] [ drop f t ] } - { [ t ] [ drop f f ] } + [ drop f f ] } cond ] if ; diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 9d41d6eae1..8447d1be5f 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -36,7 +36,7 @@ DEFER: (flat-length) ! 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 ) @@ -45,7 +45,7 @@ DEFER: (flat-length) { [ dup quotation? ] [ (flat-length) 1+ ] } { [ dup array? ] [ (flat-length) ] } { [ dup word? ] [ word-flat-length ] } - { [ t ] [ drop 1 ] } + [ drop 1 ] } cond ] map sum ; @@ -94,7 +94,7 @@ DEFER: (flat-length) dup node-param { { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } - { [ t ] [ 2drop t ] } + [ 2drop t ] } cond ; ! Resolve type checks at compile time where possible @@ -217,5 +217,5 @@ M: #call optimize-node* { [ dup optimize-predicate? ] [ optimize-predicate ] } { [ dup optimistic-inline? ] [ optimistic-inline ] } { [ dup method-body-inline? ] [ optimistic-inline ] } - { [ t ] [ inline-method ] } + [ inline-method ] } cond dup not ; diff --git a/core/optimizer/pattern-match/pattern-match.factor b/core/optimizer/pattern-match/pattern-match.factor index 0e7e801938..5beb2555f0 100755 --- a/core/optimizer/pattern-match/pattern-match.factor +++ b/core/optimizer/pattern-match/pattern-match.factor @@ -19,7 +19,7 @@ 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 -- ? ) diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index d115d0a1c6..b33a9e8fc2 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -57,7 +57,7 @@ IN: optimizer.specializers [ dup "specializer" word-prop ] [ "specializer" word-prop specialize-quot ] } - { [ t ] [ drop ] } + [ drop ] } cond ; : specialized-length ( specializer -- n ) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 6c09e08f84..1e1d6a5606 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -324,7 +324,7 @@ M: staging-violation summary { [ 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 ) diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 03d3e456ca..e1a53696af 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -107,7 +107,7 @@ SYMBOL: -> { [ dup word? not ] [ , ] } { [ dup "break?" word-prop ] [ drop ] } { [ dup "step-into?" word-prop ] [ remove-step-into ] } - { [ t ] [ , ] } + [ , ] } cond ] each ] [ ] make ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 005672c1c6..0c759265e9 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -61,7 +61,7 @@ IN: bootstrap.syntax scan { { [ dup length 1 = ] [ first ] } { [ "\\" ?head ] [ next-escape drop ] } - { [ t ] [ name>char-hook get call ] } + [ name>char-hook get call ] } cond parsed ] define-syntax diff --git a/core/threads/threads.factor b/core/threads/threads.factor index d7d7988893..d568153034 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -86,7 +86,7 @@ PRIVATE> { { [ 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 ; Date: Fri, 11 Apr 2008 12:53:46 -0500 Subject: [PATCH 653/886] refactor tar a bit --- extra/tar/tar.factor | 81 +++++++++++++++----------------------------- 1 file changed, 28 insertions(+), 53 deletions(-) diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 99af06b80f..038078969d 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -1,7 +1,7 @@ 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 ; @@ -79,87 +79,67 @@ SYMBOL: filename ] keep ] if ; -TUPLE: unknown-typeflag str ; -: ( ch -- obj ) - 1string \ unknown-typeflag construct-boa ; - -TUPLE: unimplemented-typeflag header ; -: ( header -- obj ) - global [ "Unimplemented typeflag: " print dup . flush ] bind - tar-header-typeflag - 1string \ unimplemented-typeflag construct-boa ; +ERROR: unknown-typeflag ch ; +M: unknown-typeflag summary ( obj -- str ) + ch>> 1string + "Unknown typeflag: " prepend ; : tar-append-path ( path -- newpath ) base-dir get prepend-path ; ! Normal file : typeflag-0 - tar-header-name tar-append-path binary + name>> tar-append-path binary [ read-data-blocks ] keep dispose ; ! Hard link -: typeflag-1 ( header -- ) - throw ; +: typeflag-1 ( header -- ) unknown-typeflag ; ! Symlink -: typeflag-2 ( header -- ) - throw ; +: typeflag-2 ( header -- ) unknown-typeflag ; ! character special -: typeflag-3 ( header -- ) - throw ; +: typeflag-3 ( header -- ) unknown-typeflag ; ! Block special -: typeflag-4 ( header -- ) - throw ; +: typeflag-4 ( header -- ) unknown-typeflag ; ! Directory : typeflag-5 ( header -- ) tar-header-name tar-append-path make-directories ; ! FIFO -: typeflag-6 ( header -- ) - throw ; +: typeflag-6 ( header -- ) unknown-typeflag ; ! Contiguous file -: typeflag-7 ( header -- ) - throw ; +: typeflag-7 ( header -- ) unknown-typeflag ; ! Global extended header -: typeflag-8 ( header -- ) - throw ; +: typeflag-8 ( header -- ) unknown-typeflag ; ! Extended header -: typeflag-9 ( header -- ) - throw ; +: typeflag-9 ( header -- ) unknown-typeflag ; ! Global POSIX header -: typeflag-g ( header -- ) - throw ; +: typeflag-g ( header -- ) unknown-typeflag ; ! Extended POSIX header -: typeflag-x ( header -- ) - throw ; +: typeflag-x ( header -- ) unknown-typeflag ; ! Solaris access control list -: typeflag-A ( header -- ) - throw ; +: typeflag-A ( header -- ) unknown-typeflag ; ! GNU dumpdir -: typeflag-D ( header -- ) - throw ; +: typeflag-D ( header -- ) unknown-typeflag ; ! Solaris extended attribute file -: typeflag-E ( header -- ) - throw ; +: typeflag-E ( header -- ) unknown-typeflag ; ! Inode metadata -: typeflag-I ( header -- ) - throw ; +: typeflag-I ( header -- ) unknown-typeflag ; ! Long link name -: typeflag-K ( header -- ) - throw ; +: typeflag-K ( header -- ) unknown-typeflag ; ! Long file name : typeflag-L ( header -- ) @@ -169,24 +149,19 @@ TUPLE: unimplemented-typeflag header ; filename get tar-append-path make-directories ; ! Multi volume continuation entry -: typeflag-M ( header -- ) - throw ; +: typeflag-M ( header -- ) unknown-typeflag ; ! GNU long file name -: typeflag-N ( header -- ) - throw ; +: typeflag-N ( header -- ) unknown-typeflag ; ! Sparse file -: typeflag-S ( header -- ) - throw ; +: typeflag-S ( header -- ) unknown-typeflag ; ! Volume header -: typeflag-V ( header -- ) - throw ; +: typeflag-V ( header -- ) unknown-typeflag ; ! Vendor extended header type -: typeflag-X ( header -- ) - throw ; +: typeflag-X ( header -- ) unknown-typeflag ; : (parse-tar) ( -- ) 512 read @@ -218,7 +193,7 @@ TUPLE: unimplemented-typeflag header ; { CHAR: S [ typeflag-S ] } { CHAR: V [ typeflag-V ] } { CHAR: X [ typeflag-X ] } - [ throw ] + [ unknown-typeflag ] } case ! dup tar-header-size zero? [ ! out-stream get [ dispose ] when @@ -237,7 +212,7 @@ TUPLE: unimplemented-typeflag header ; : 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) From 1e01d73e616de962e68b2bab525724c02caa98dd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 11 Apr 2008 12:54:33 -0500 Subject: [PATCH 654/886] fix usages of cond/case --- extra/ui/gadgets/buttons/buttons.factor | 2 +- extra/ui/gadgets/gadgets.factor | 2 +- extra/ui/gadgets/panes/panes.factor | 2 +- extra/ui/gadgets/scrollers/scrollers.factor | 2 +- extra/ui/gestures/gestures.factor | 2 +- extra/ui/render/render.factor | 2 +- extra/ui/tools/interactor/interactor.factor | 6 +++--- extra/ui/tools/listener/listener.factor | 2 +- extra/ui/tools/walker/walker.factor | 2 +- extra/ui/traverse/traverse.factor | 2 +- extra/ui/windows/windows.factor | 4 ++-- extra/ui/x11/x11.factor | 4 ++-- 12 files changed, 16 insertions(+), 16 deletions(-) diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index 7e649b7ff7..978e5d48e2 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -55,7 +55,7 @@ C: button-paint { [ 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 diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 3ad76b0a16..f4e5ca2a46 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -378,7 +378,7 @@ SYMBOL: in-layout? { { [ 2dup eq? ] [ 2drop t ] } { [ dup not ] [ 2drop f ] } - { [ t ] [ gadget-parent child? ] } + [ gadget-parent child? ] } cond ; GENERIC: focusable-child* ( gadget -- child/t ) diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index fedacbd2af..439e938186 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -88,7 +88,7 @@ C: pane-stream dup gadget-children { { [ dup empty? ] [ 2drop ""
( 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" ; diff --git a/extra/html/html-tests.factor b/extra/html/html-tests.factor index 2994e2d792..cac6526376 100644 --- a/extra/html/html-tests.factor +++ b/extra/html/html-tests.factor @@ -32,7 +32,7 @@ M: funky browser-link-href [ "<" ] [ [ - "<" "austin" funky construct-boa write-object + "<" "austin" funky boa write-object ] make-html-string ] unit-test diff --git a/extra/html/html.factor b/extra/html/html.factor index 0619937332..84597731d1 100755 --- a/extra/html/html.factor +++ b/extra/html/html.factor @@ -32,7 +32,7 @@ TUPLE: html-stream last-div? ; TUPLE: html-sub-stream style stream ; : (html-sub-stream) ( style stream -- stream ) - html-sub-stream construct-boa + html-sub-stream boa 512 over set-delegate ; : ( style stream class -- stream ) diff --git a/extra/http/http.factor b/extra/http/http.factor index a6afe80443..d894059b6f 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -122,7 +122,7 @@ IN: http TUPLE: cookie name value path domain expires http-only ; : ( value name -- cookie ) - cookie construct-empty + cookie new swap >>name swap >>value ; : parse-cookies ( string -- seq ) @@ -176,7 +176,7 @@ post-data-type cookies ; : - request construct-empty + request new "1.1" >>version http-port >>port H{ } clone >>header @@ -346,7 +346,7 @@ cookies body ; : - response construct-empty + response new "1.1" >>version H{ } clone >>header "close" "connection" set-header @@ -434,7 +434,7 @@ message body ; : ( -- response ) - raw-response construct-empty + raw-response new "1.1" >>version ; M: raw-response write-response ( respose -- ) diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index fcafa57ff6..fabddcdeb1 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -12,7 +12,7 @@ SYMBOL: params TUPLE: action init display submit get-params post-params ; : - action construct-empty + action new [ ] >>init [ <400> ] >>display [ <400> ] >>submit ; diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor index 18ec8da62a..54f96480bc 100755 --- a/extra/http/server/auth/providers/assoc/assoc.factor +++ b/extra/http/server/auth/providers/assoc/assoc.factor @@ -7,7 +7,7 @@ http.server.auth.providers ; TUPLE: users-in-memory assoc ; : ( -- provider ) - H{ } clone users-in-memory construct-boa ; + H{ } clone users-in-memory boa ; M: users-in-memory get-user ( username provider -- user/f ) assoc>> at ; diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor index eda3babf0f..3d8f1760db 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/http/server/auth/providers/providers.factor @@ -6,7 +6,7 @@ IN: http.server.auth.providers TUPLE: user username realname password email ticket profile ; -: user construct-empty H{ } clone >>profile ; +: user new H{ } clone >>profile ; GENERIC: get-user ( username provider -- user/f ) diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor index e1b737a9c6..42213d015f 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/http/server/callbacks/callbacks.factor @@ -14,7 +14,7 @@ TUPLE: callback-responder responder callbacks ; #! A continuation responder is a special type of session #! manager. However it works entirely differently from #! the URL and cookie session managers. - H{ } clone callback-responder construct-boa ; + H{ } clone callback-responder boa ; TUPLE: callback cont quot expires alarm responder ; @@ -32,7 +32,7 @@ TUPLE: callback cont quot expires alarm responder ; ] when drop ; : ( cont quot expires? -- callback ) - f callback-responder get callback construct-boa + f callback-responder get callback boa dup touch-callback ; : invoke-callback ( callback -- response ) diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor index d372865b7e..1cd215ee5d 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -42,7 +42,7 @@ validation-failed? off TUPLE: test-tuple text number more-text ; -: test-tuple construct-empty ; +: test-tuple new ; : ( -- form ) "test"
diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index bd95bf4407..255cb5bfb8 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -50,7 +50,7 @@ SYMBOL: values ] if ; : ( id class -- component ) - \ component construct-empty + \ component new swap construct-delegate swap >>id ; inline diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index e1561bce89..e59ca5c174 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -106,7 +106,7 @@ SYMBOL: form-hook TUPLE: dispatcher default responders ; : ( -- dispatcher ) - 404-responder get H{ } clone dispatcher construct-boa ; + 404-responder get H{ } clone dispatcher boa ; : split-path ( path -- rest first ) [ CHAR: / = ] left-trim "/" split1 swap ; @@ -131,7 +131,7 @@ M: dispatcher call-responder ( path dispatcher -- response ) TUPLE: vhost-dispatcher default responders ; : ( -- 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* diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index a3d06e8f18..1288b4f7a4 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -18,7 +18,7 @@ M: object init-session* drop ; TUPLE: session-manager responder sessions ; : ( responder class -- responder' ) - >r session-manager construct-boa + >r session-manager boa r> construct-delegate ; inline SYMBOLS: session session-id session-changed? ; diff --git a/extra/http/server/sessions/storage/assoc/assoc.factor b/extra/http/server/sessions/storage/assoc/assoc.factor index 4bdc52b86e..6e4a84d646 100755 --- a/extra/http/server/sessions/storage/assoc/assoc.factor +++ b/extra/http/server/sessions/storage/assoc/assoc.factor @@ -7,7 +7,7 @@ IN: http.server.sessions.storage.assoc TUPLE: sessions-in-memory sessions alarms ; : ( -- storage ) - H{ } clone H{ } clone sessions-in-memory construct-boa ; + H{ } clone H{ } clone sessions-in-memory boa ; : cancel-session-timeout ( id storage -- ) alarms>> at [ cancel-alarm ] when* ; diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor index e573b22ba1..0245db15b0 100755 --- a/extra/http/server/sessions/storage/db/db.factor +++ b/extra/http/server/sessions/storage/db/db.factor @@ -18,7 +18,7 @@ session "SESSIONS" : init-sessions-table session ensure-table ; : ( id -- session ) - session construct-empty + session new swap dup [ string>number ] when >>id ; M: sessions-in-db get-session ( id storage -- namespace/f ) diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 8632e0f139..2d4a97c3c0 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -21,7 +21,7 @@ TUPLE: file-responder root hook special ; 304 "Not modified" ; : ( root hook -- responder ) - H{ } clone file-responder construct-boa ; + H{ } clone file-responder boa ; : ( root -- responder ) [ diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index 101637e4e8..0df41cf53f 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -61,7 +61,7 @@ C: nil [ f ] [ 1 2 [ ] 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 diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 6852d70e48..7a2856e311 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -6,7 +6,7 @@ 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 ; @@ -26,7 +26,7 @@ M: fail summary drop "Unification failed" ; "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" ; @@ -214,14 +214,14 @@ DEFER: _ : 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 @@ -255,7 +255,7 @@ DEFER: _ 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 ) diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index 8b00e59d23..a901475544 100755 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -9,7 +9,7 @@ accessors ; TUPLE: buffer size ptr fill pos ; : ( 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 ; diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index 04e8ee8569..dc6e52d67e 100755 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -70,7 +70,7 @@ M: 8-bit decode-char decode>> decode-8-bit ; : make-8-bit ( word byte>ch ch>byte -- ) - [ 8-bit construct-boa ] 2curry dupd curry define ; + [ 8-bit boa ] 2curry dupd curry define ; : define-8-bit-encoding ( name stream -- ) >r in get create r> parse-file make-8-bit ; diff --git a/extra/io/encodings/strict/strict.factor b/extra/io/encodings/strict/strict.factor index 89c10d89cc..21eb231075 100644 --- a/extra/io/encodings/strict/strict.factor +++ b/extra/io/encodings/strict/strict.factor @@ -7,7 +7,7 @@ TUPLE: strict code ; C: strict strict TUPLE: decode-error ; -: decode-error ( -- * ) \ decode-error construct-empty throw ; +: decode-error ( -- * ) \ decode-error new throw ; M: decode-error summary drop "Error in decoding input stream" ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 00352adc7b..c5cd7b24eb 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -41,7 +41,7 @@ SYMBOL: +highest-priority+ SYMBOL: +realtime-priority+ : ( -- process ) - process construct-empty + process new H{ } clone >>environment +append-environment+ >>environment-mode ; @@ -130,7 +130,7 @@ HOOK: run-process* io-backend ( process -- handle ) TUPLE: process-failed code ; : process-failed ( code -- * ) - \ process-failed construct-boa throw ; + \ process-failed boa throw ; : try-process ( desc -- ) run-process wait-for-process dup zero? diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 5c88968ee7..a9b3d414ba 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -28,7 +28,7 @@ M: monitor timeout timeout>> ; M: monitor set-timeout (>>timeout) ; : construct-monitor ( path mailbox class -- monitor ) - construct-empty + new swap >>queue swap >>path ; inline diff --git a/extra/io/monitors/recursive/recursive-tests.factor b/extra/io/monitors/recursive/recursive-tests.factor index 3182747194..c35401af83 100644 --- a/extra/io/monitors/recursive/recursive-tests.factor +++ b/extra/io/monitors/recursive/recursive-tests.factor @@ -30,8 +30,8 @@ M: mock-io-backend (monitor) M: mock-io-backend link-info global [ link-info ] bind ; -[ ] [ 0 counter construct-boa dummy-monitor-created set ] unit-test -[ ] [ 0 counter construct-boa dummy-monitor-disposed set ] unit-test +[ ] [ 0 counter boa dummy-monitor-created set ] unit-test +[ ] [ 0 counter boa dummy-monitor-disposed set ] unit-test [ ] [ mock-io-backend io-backend [ diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index aa56b507ff..0bf7a6ccec 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -20,7 +20,7 @@ GENERIC: init-handle ( handle -- ) GENERIC: close-handle ( handle -- ) : ( handle class -- port ) - construct-empty + new swap dup init-handle >>handle ; inline : ( handle class -- port ) diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index dad1087022..171f8122c5 100755 --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -14,7 +14,7 @@ TUPLE: directory-iterator path bfs queue ; ] curry each ; : ( path bfs? -- iterator ) - directory-iterator construct-boa + directory-iterator boa dup path>> over push-directory ; : next-file ( iter -- file/f ) diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 04141c56ef..859dcb4cdc 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -7,7 +7,7 @@ IN: io.sockets TUPLE: local path ; : ( path -- addrspec ) - normalize-path local construct-boa ; + normalize-path local boa ; TUPLE: inet4 host port ; diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 396b8cf2e8..6bd3747ce3 100644 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -14,7 +14,7 @@ TUPLE: io-task port callbacks ; : io-task-fd port>> handle>> ; : ( port continuation/f class -- task ) - construct-empty + new swap [ 1vector ] [ V{ } clone ] if* >>callbacks swap >>port ; inline @@ -33,7 +33,7 @@ M: input-task io-task-container drop reads>> ; M: output-task io-task-container drop writes>> ; : construct-mx ( class -- obj ) - construct-empty + new H{ } clone >>reads H{ } clone >>writes ; inline diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 5873568a9e..a09ebb46c9 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -94,7 +94,7 @@ M: unix copy-file ( from to -- ) [ stat-st_mode ] [ stat-st_mtim timespec-sec seconds unix-1970 time+ ] } cleave - \ file-info construct-boa ; + \ file-info boa ; M: unix file-info ( path -- info ) normalize-path stat* stat>file-info ; diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor index f042366b13..2815a49cd3 100755 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -13,7 +13,7 @@ IN: io.unix.mmap M: unix ( 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 close-mapped-file ( mmap -- ) [ mapped-file-address ] keep diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index 8bfbff2ba0..8a15a57f83 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -48,7 +48,7 @@ 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" [ @@ -69,7 +69,7 @@ SYMBOLS: +read-only+ +hidden+ +system+ [ 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 ) [ diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 04e149d261..670ea18f5e 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -23,7 +23,7 @@ TUPLE: CreateProcess-args stdout-pipe stdin-pipe ; : default-CreateProcess-args ( -- obj ) - CreateProcess-args construct-empty + CreateProcess-args new "STARTUPINFO" "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo "PROCESS_INFORMATION" >>lpProcessInformation diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index 8d3690bbb5..0164ed1697 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -78,7 +78,7 @@ M: windows ( path length -- mmap ) 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 close-mapped-file ( mapped-file -- ) diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor index f2aca0470d..b164d5872b 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -37,7 +37,7 @@ TUPLE: pipe in out ; [ >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 -- ) diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 1617b9f9a0..79e767177d 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -52,7 +52,7 @@ TUPLE: ConnectEx-args port 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 @@ -123,7 +123,7 @@ M: winnt (accept) ( server -- addrspec handle ) [ [ check-server-port - \ AcceptEx-args construct-empty + \ AcceptEx-args new [ init-accept ] keep [ ((accept)) ] keep [ accept-continuation ] keep @@ -193,7 +193,7 @@ TUPLE: WSARecvFrom-args port M: winnt receive ( datagram -- packet addrspec ) [ check-datagram-port - \ WSARecvFrom-args construct-empty + \ WSARecvFrom-args new [ init-WSARecvFrom ] keep [ call-WSARecvFrom ] keep [ WSARecvFrom-continuation ] keep @@ -245,7 +245,7 @@ USE: io.sockets M: winnt send ( packet addrspec datagram -- ) [ check-datagram-send - \ WSASendTo-args construct-empty + \ WSASendTo-args new [ init-WSASendTo ] keep [ call-WSASendTo ] keep [ WSASendTo-continuation ] keep diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index d4e202013b..772ad9124f 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -155,7 +155,7 @@ HOOK: WSASocket-flags io-backend ( -- DWORD ) TUPLE: win32-socket < win32-file ; : ( handle -- win32-socket ) - f win32-file construct-boa ; + f win32-file boa ; : open-socket ( family type -- socket ) 0 f 0 WSASocket-flags WSASocket dup socket-error ; diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor index 27f82b25eb..4dda206c7b 100755 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -39,14 +39,14 @@ TUPLE: irc-client profile nick stream stream-channel controller-channel listeners is-running ; : ( profile -- irc-client ) f V{ } clone V{ } clone - f V{ } clone f irc-client construct-boa ; + f 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?? : ( quot -- irc-listener ) - irc-listener construct-boa swap + irc-listener boa swap [ [ channel>> '[ , from ] ] [ '[ , curry f spawn drop ] ] diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor index f82ee91d22..3842816f0e 100644 --- a/extra/jamshred/game/game.factor +++ b/extra/jamshred/game/game.factor @@ -8,7 +8,7 @@ TUPLE: jamshred tunnel players running ; : ( -- jamshred ) "Player 1" 2dup swap play-in-tunnel 1array f - jamshred construct-boa ; + jamshred boa ; : jamshred-player ( jamshred -- player ) ! TODO: support more than one player diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index bcf4597307..11a89b314f 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -11,7 +11,7 @@ IN: jamshred.oint TUPLE: oint location forward up left ; : ( location forward up left -- oint ) - oint construct-boa ; + oint boa ; ! : x-rotation ( theta -- matrix ) ! #! construct this matrix: diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 6cc433903e..17843ef9c2 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -7,7 +7,7 @@ IN: jamshred.player TUPLE: player name tunnel nearest-segment ; : ( 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 } over set-delegate ; : turn-player ( player x-radians y-radians -- ) diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 7be406d37a..d5ee7f3ebc 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -9,7 +9,7 @@ IN: jamshred.tunnel TUPLE: segment number color radius ; : ( number color radius location forward up left -- segment ) - >r segment construct-boa r> over set-delegate ; + >r segment boa r> over set-delegate ; : segment-vertex ( theta segment -- vertex ) tuck 2dup oint-up swap sin v*n diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index ebd2fe9f2e..b87a1e5f2e 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -52,7 +52,7 @@ M: cons nil? ( cons -- bool ) TUPLE: lazy-cons car cdr ; : lazy-cons ( car cdr -- promise ) - [ promise ] bi@ \ lazy-cons construct-boa + [ promise ] bi@ \ lazy-cons boa T{ promise f f t f } clone [ set-promise-value ] keep ; @@ -103,7 +103,7 @@ TUPLE: memoized-cons original car cdr nil? ; : ( 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? [ diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor index 5b805fa260..40de92e3b1 100644 --- a/extra/math/erato/erato.factor +++ b/extra/math/erato/erato.factor @@ -22,7 +22,7 @@ TUPLE: erato limit bits latest ; [ [ indices ] keep erato-bits [ f -rot set-nth ] curry each ] [ 2drop ] if ; : ( n -- erato ) - dup ind 1+ 1 over set-bits erato construct-boa ; + dup ind 1+ 1 over set-bits erato boa ; : next-prime ( erato -- prime/f ) [ erato-latest 2 + ] keep [ set-erato-latest ] 2keep diff --git a/extra/math/ranges/ranges.factor b/extra/math/ranges/ranges.factor index 9215fc3acd..81b7f63427 100755 --- a/extra/math/ranges/ranges.factor +++ b/extra/math/ranges/ranges.factor @@ -6,7 +6,7 @@ TUPLE: range from length step ; : ( a b step -- range ) >r over - r> [ / 1+ 0 max >integer ] keep - range construct-boa ; + range boa ; M: range length ( seq -- n ) range-length ; diff --git a/extra/models/models-tests.factor b/extra/models/models-tests.factor index bd02c2f708..7964f8929e 100755 --- a/extra/models/models-tests.factor +++ b/extra/models/models-tests.factor @@ -4,7 +4,7 @@ tools.test ; TUPLE: model-tester hit? ; -: model-tester construct-empty ; +: model-tester new ; M: model-tester model-changed nip t swap set-model-tester-hit? ; diff --git a/extra/models/models.factor b/extra/models/models.factor index ffb9b1127a..58335de3d1 100755 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -8,7 +8,7 @@ TUPLE: model < identity-tuple value connections dependencies ref locked? ; : ( value -- model ) - V{ } clone V{ } clone 0 f model construct-boa ; + V{ } clone V{ } clone 0 f model boa ; M: model hashcode* drop model hashcode* ; diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 36d24e1300..ab9ae38ac1 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -159,7 +159,7 @@ MACRO: set-draw-buffers ( buffers -- ) TUPLE: sprite loc dim dim2 dlist texture ; : ( loc dim dim2 -- sprite ) - f f sprite construct-boa ; + f f sprite boa ; : sprite-size2 sprite-dim2 first2 ; diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index a726095eb1..3ae0c94b12 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -19,7 +19,7 @@ M: comment pprint* swap comment-node present-text ; : comment, ( ? node text -- ) - rot [ \ comment construct-boa , ] [ 2drop ] if ; + rot [ \ comment boa , ] [ 2drop ] if ; : values% ( prefix values -- ) swap [ diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index d8fccfb8f9..40620295c6 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -113,7 +113,7 @@ M: fail-parser parse ( input parser -- list ) 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? @@ -122,7 +122,7 @@ M: ensure-parser parse ( input parser -- list ) 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? @@ -135,10 +135,10 @@ TUPLE: and-parser parsers ; >r and-parser-parsers r> suffix ] [ 2array - ] if and-parser construct-boa ; + ] if and-parser boa ; : ( 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 [ @@ -161,7 +161,7 @@ M: and-parser parse ( input parser -- list ) TUPLE: or-parser parsers ; : ( parsers -- parser ) - dup length 1 = [ first ] [ or-parser construct-boa ] if ; + dup length 1 = [ first ] [ or-parser boa ] if ; : <|> ( parser1 parser2 -- parser ) 2array ; @@ -265,7 +265,7 @@ LAZY: ( parser -- parser ) 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 diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 3bbb61b846..da7f678f2d 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -20,7 +20,7 @@ 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 ; : 1token ( ch -- parser ) 1string token ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 7390c15684..544e5f95c2 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -21,7 +21,7 @@ C: parser SYMBOL: ignore : ( remaining ast -- parse-result ) - parse-result construct-boa ; + parse-result boa ; SYMBOL: packrat SYMBOL: pos @@ -468,16 +468,16 @@ M: box-parser (compile) ( parser -- quot ) PRIVATE> : token ( string -- parser ) - token-parser construct-boa init-parser ; + token-parser boa init-parser ; : satisfy ( quot -- parser ) - satisfy-parser construct-boa init-parser ; + satisfy-parser boa init-parser ; : range ( min max -- parser ) - range-parser construct-boa init-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 ; @@ -492,7 +492,7 @@ PRIVATE> { } make seq ; inline : choice ( seq -- parser ) - choice-parser construct-boa init-parser ; + choice-parser boa init-parser ; : 2choice ( parser1 parser2 -- parser ) 2array choice ; @@ -507,34 +507,34 @@ PRIVATE> { } make choice ; inline : repeat0 ( parser -- parser ) - repeat0-parser construct-boa init-parser ; + repeat0-parser boa init-parser ; : repeat1 ( parser -- parser ) - repeat1-parser construct-boa init-parser ; + repeat1-parser boa init-parser ; : optional ( parser -- parser ) - optional-parser construct-boa init-parser ; + optional-parser boa init-parser ; : semantic ( parser quot -- parser ) - semantic-parser construct-boa init-parser ; + semantic-parser boa init-parser ; : ensure ( parser -- parser ) - ensure-parser construct-boa init-parser ; + ensure-parser boa init-parser ; : ensure-not ( parser -- parser ) - ensure-not-parser construct-boa init-parser ; + ensure-not-parser boa init-parser ; : action ( parser quot -- parser ) - action-parser construct-boa init-parser ; + action-parser boa init-parser ; : sp ( parser -- parser ) - sp-parser construct-boa init-parser ; + sp-parser boa init-parser ; : hide ( parser -- parser ) [ drop ignore ] action ; : delay ( quot -- parser ) - delay-parser construct-boa init-parser ; + delay-parser boa init-parser ; : box ( quot -- parser ) #! because a box has its quotation run at compile time @@ -548,7 +548,7 @@ PRIVATE> #! 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 construct-boa next-id f over set-delegate [ ] action ; + box-parser boa next-id f over set-delegate [ ] action ; : PEG: (:) [ diff --git a/extra/processing/gadget/gadget.factor b/extra/processing/gadget/gadget.factor index 8b78c43f00..bac3f8ac6d 100644 --- a/extra/processing/gadget/gadget.factor +++ b/extra/processing/gadget/gadget.factor @@ -18,7 +18,7 @@ TUPLE: processing-gadget button-down button-up key-down key-up ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : ( -- gadget ) - processing-gadget construct-empty + processing-gadget new set-gadget-delegate ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/promises/promises.factor b/extra/promises/promises.factor index 469f6a91ed..2126f0c05d 100755 --- a/extra/promises/promises.factor +++ b/extra/promises/promises.factor @@ -11,7 +11,7 @@ IN: promises TUPLE: promise quot forced? value ; : promise ( quot -- promise ) - f f \ promise construct-boa ; + f f \ promise boa ; : promise-with ( value quot -- promise ) curry promise ; diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor index 5644cf6d08..db8fe540e5 100755 --- a/extra/random/blum-blum-shub/blum-blum-shub.factor +++ b/extra/random/blum-blum-shub/blum-blum-shub.factor @@ -15,7 +15,7 @@ TUPLE: blum-blum-shub x n ; : ( numbits -- blum-blum-shub ) generate-bbs-primes * [ find-relative-prime ] keep - blum-blum-shub construct-boa ; + blum-blum-shub boa ; : next-bbs-bit ( bbs -- bit ) [ [ x>> 2 ] [ n>> ] bi ^mod ] keep diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index 46f2088440..01e79abff2 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -58,7 +58,7 @@ TUPLE: mersenne-twister seq i ; PRIVATE> : ( seed -- obj ) - init-mt-seq 0 mersenne-twister construct-boa + init-mt-seq 0 mersenne-twister boa dup mt-generate ; M: mersenne-twister seed-random ( mt seed -- ) diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index b0cd61bd8f..6b344ad140 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -269,7 +269,7 @@ TUPLE: regexp source parser ignore-case? ; 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 ; diff --git a/extra/roman/roman.factor b/extra/roman/roman.factor index a3e61dd889..07e43cea8e 100644 --- a/extra/roman/roman.factor +++ b/extra/roman/roman.factor @@ -19,7 +19,7 @@ TUPLE: roman-range-error n ; dup 1 3999 between? [ drop ] [ - roman-range-error construct-boa throw + roman-range-error boa throw ] if ; : roman<= ( ch1 ch2 -- ? ) diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index 27e0159596..2de0e1c67e 100755 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -5,10 +5,10 @@ IN: semantic-db TUPLE: node id content ; : ( content -- node ) - node construct-empty swap >>content ; + node new swap >>content ; : ( id -- node ) - node construct-empty swap >>id ; + node new swap >>id ; node "node" { @@ -34,10 +34,10 @@ node "node" TUPLE: arc id relation subject object ; : ( relation subject object -- arc ) - arc construct-empty swap >>object swap >>subject swap >>relation ; + arc new swap >>object swap >>subject swap >>relation ; : ( id -- arc ) - arc construct-empty swap >>id ; + arc new swap >>id ; : insert-arc ( arc -- ) f dup insert-tuple id>> >>id insert-tuple ; diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index 280ce3b43e..9107c0145a 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -277,7 +277,7 @@ SYMBOL: deserialized : deserialize-tuple ( -- array ) #! Ugly because we have to intern the tuple before reading #! slots - (deserialize) construct-empty + (deserialize) new [ intern-object ] [ [ (deserialize) ] diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 844857d1db..8e84f99fe1 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -149,7 +149,7 @@ M: email clone message-id "Message-Id" set-header ; : ( -- email ) - email construct-empty + email new H{ } clone >>headers ; : send-email ( email -- ) diff --git a/extra/state-machine/state-machine.factor b/extra/state-machine/state-machine.factor index 489b7aaeb4..3f1d91d84c 100755 --- a/extra/state-machine/state-machine.factor +++ b/extra/state-machine/state-machine.factor @@ -12,7 +12,7 @@ IN: state-machine 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 ; diff --git a/extra/state-parser/state-parser.factor b/extra/state-parser/state-parser.factor index 3f51a52e1b..cb0362609a 100644 --- a/extra/state-parser/state-parser.factor +++ b/extra/state-parser/state-parser.factor @@ -23,7 +23,7 @@ C: spot ! * Errors TUPLE: parsing-error line column ; : ( -- parsing-error ) - get-line get-column parsing-error construct-boa ; + get-line get-column parsing-error boa ; : construct-parsing-error ( ... slots class -- error ) construct over set-delegate ; inline diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 038078969d..9b3d2ae79f 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -9,7 +9,7 @@ IN: tar TUPLE: tar-header name mode uid gid size mtime checksum typeflag linkname magic version uname gname devmajor devminor prefix ; -: ( -- obj ) tar-header construct-empty ; +: ( -- obj ) tar-header new ; : tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ; @@ -68,13 +68,13 @@ SYMBOL: filename : 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 ; diff --git a/extra/taxes/taxes.factor b/extra/taxes/taxes.factor index d557feabfa..f1f3868ec8 100644 --- a/extra/taxes/taxes.factor +++ b/extra/taxes/taxes.factor @@ -45,7 +45,7 @@ GENERIC: withholding ( salary w4 collector -- x ) TUPLE: tax-table single married ; : ( 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 - ; diff --git a/extra/tetris/board/board.factor b/extra/tetris/board/board.factor index 93bbebf34f..532978e359 100644 --- a/extra/tetris/board/board.factor +++ b/extra/tetris/board/board.factor @@ -9,7 +9,7 @@ TUPLE: board width height rows ; [ drop f ] with map ; : ( 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. diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor index 2fa3efcf7b..5c88187c6c 100755 --- a/extra/trees/avl/avl.factor +++ b/extra/trees/avl/avl.factor @@ -14,7 +14,7 @@ INSTANCE: avl tree-mixin TUPLE: avl-node balance ; : ( key value -- node ) - swap 0 avl-node construct-boa tuck set-delegate ; + swap 0 avl-node boa tuck set-delegate ; : change-balance ( node amount -- ) over avl-node-balance + swap set-avl-node-balance ; diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor index 7746db85d3..4b82f86a57 100644 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -107,7 +107,7 @@ DEFER: (splay) 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 -- ) diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index 1648eeec32..07497b2098 100755 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -10,10 +10,10 @@ MIXIN: tree-mixin TUPLE: tree root count ; : ( -- tree ) - f 0 tree construct-boa ; + f 0 tree boa ; : construct-tree ( class -- tree ) - construct-empty over set-delegate ; inline + new over set-delegate ; inline INSTANCE: tree tree-mixin @@ -21,7 +21,7 @@ INSTANCE: tree-mixin assoc TUPLE: node key value left right ; : ( key value -- node ) - f f node construct-boa ; + f f node boa ; SYMBOL: current-side diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor index 2419b8febb..219df5197c 100755 --- a/extra/tuple-syntax/tuple-syntax.factor +++ b/extra/tuple-syntax/tuple-syntax.factor @@ -15,4 +15,4 @@ IN: tuple-syntax [ 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 diff --git a/extra/turtle/turtle.factor b/extra/turtle/turtle.factor index b9a932306a..24f93b56fc 100644 --- a/extra/turtle/turtle.factor +++ b/extra/turtle/turtle.factor @@ -8,7 +8,7 @@ IN: turtle TUPLE: turtle ; : ( -- turtle ) -turtle construct-empty +turtle new { 0 0 0 } clone 3 identity-matrix rot diff --git a/extra/ui/clipboards/clipboards.factor b/extra/ui/clipboards/clipboards.factor index fa6cc75ba6..ab6cc35d8c 100644 --- a/extra/ui/clipboards/clipboards.factor +++ b/extra/ui/clipboards/clipboards.factor @@ -5,7 +5,7 @@ IN: ui.clipboards ! Two text transfer buffers TUPLE: clipboard contents ; -: "" clipboard construct-boa ; +: "" clipboard boa ; GENERIC: paste-clipboard ( gadget clipboard -- ) diff --git a/extra/ui/gadgets/borders/borders.factor b/extra/ui/gadgets/borders/borders.factor index 6b548aaf68..91d20e9c99 100644 --- a/extra/ui/gadgets/borders/borders.factor +++ b/extra/ui/gadgets/borders/borders.factor @@ -7,7 +7,7 @@ IN: ui.gadgets.borders TUPLE: border size fill ; : ( child gap -- border ) - dup 2array { 0 0 } border construct-boa + dup 2array { 0 0 } border boa over set-delegate tuck add-gadget ; diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index 978e5d48e2..9910082ebf 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -40,7 +40,7 @@ button H{ } set-gestures :
+ + + diff --git a/extra/webapps/todo/page.xml b/extra/webapps/todo/page.xml new file mode 100644 index 0000000000..f40c79d299 --- /dev/null +++ b/extra/webapps/todo/page.xml @@ -0,0 +1,45 @@ + + + + + + + + + + + + + body, button { + font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif; + color:#444; + } + + 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; + } + + + + + + + + + + + + diff --git a/extra/webapps/todo/todo-list.xml b/extra/webapps/todo/todo-list.xml new file mode 100644 index 0000000000..056a9c6242 --- /dev/null +++ b/extra/webapps/todo/todo-list.xml @@ -0,0 +1,12 @@ + + + + + My Todo List + + + + +
SummaryPriorityViewEdit
+ + diff --git a/extra/webapps/todo/todo-summary.xml b/extra/webapps/todo/todo-summary.xml new file mode 100644 index 0000000000..9e03b7f135 --- /dev/null +++ b/extra/webapps/todo/todo-summary.xml @@ -0,0 +1,20 @@ + + + + + + + + + + + + + View + + + Edit + + + + diff --git a/extra/webapps/todo/todo.css b/extra/webapps/todo/todo.css new file mode 100644 index 0000000000..f7a6cfa1a2 --- /dev/null +++ b/extra/webapps/todo/todo.css @@ -0,0 +1,41 @@ +.big-field-label { + vertical-align: top; +} + +.description { + border: 1px dashed #ccc; + background-color: #f5f5f5; + padding: 5px; + font-size: 150%; + color: #000000;3 +} + +.link-button { + padding: 0px; + background: none; + border: none; +} + +.navbar { + background-color: #eeeeee; + padding: 5px; + border: 1px solid #ccc; +} + +.inline { + display: inline; +} + +pre { + font-size: 75%; +} + +.todo-list { + border-style: none; +} + +.todo-list td, .todo-list th { + border-width: 1px; + padding: 2px; + border-style: solid; +} diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor new file mode 100755 index 0000000000..6277216eef --- /dev/null +++ b/extra/webapps/todo/todo.factor @@ -0,0 +1,111 @@ +! Copyright (c) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel locals sequences +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 ; +IN: 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 ; + +: ( id -- todo ) + todo new + swap >>id + uid >>uid ; + +: todo-template ( name -- template ) + "resource:extra/webapps/todo/" swap ".xml" 3append ; + +: ( -- form ) + "todo"
+ "view-todo" todo-template >>view-template + "edit-todo" todo-template >>edit-template + "todo-summary" todo-template >>summary-template + "id" + hidden >>renderer + add-field + "summary" + t >>required + add-field + "priority" + t >>required + 0 >>default + 0 >>min-value + 10 >>max-value + add-field + "description" + add-field ; + +: ( -- form ) + "todo-list" + "todo-list" todo-template >>view-template + "list" + add-field ; + +TUPLE: todo-responder < dispatcher ; + +:: ( -- responder ) + [let | todo-form [ ] + list-form [ ] + ctor [ [ ] ] | + todo-responder new-dispatcher + list-form ctor "list" add-main-responder + todo-form ctor "view" add-responder + todo-form ctor "view" "edit" add-responder + ctor "list" "delete" add-responder + + "todo" todo-template >>template + ] ; + +! What follows below is somewhat akin to a 'deployment descriptor' +! for the todo application. The can be integrated +! into an existing web app that provides session management and +! login facilities, or can be used to run a +! self-contained todo instance. +USING: namespaces io.files io.sockets +db.sqlite smtp +http.server.sessions +http.server.auth.login +http.server.auth.providers.db +http.server.sessions.storage.db ; + +: test-db "todo.db" resource-path sqlite-db ; + +: ( -- responder ) + + + users-in-db >>users + allow-registration + allow-password-recovery + allow-edit-profile + + "page" todo-template >>template + + sessions-in-db >>sessions + test-db ; + +: init-todo ( -- ) + "factorcode.org" 25 smtp-server set-global + "todo@factorcode.org" lost-password-from set-global + + test-db [ + init-todo-table + init-users-table + init-sessions-table + ] with-db + + main-responder set-global ; diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml new file mode 100644 index 0000000000..a76ed2730f --- /dev/null +++ b/extra/webapps/todo/todo.xml @@ -0,0 +1,26 @@ + + + + + + + + +
+ List Items + | New Items + + + | Edit Profile + + + + | + +
+ +

+ + + + diff --git a/extra/webapps/todo/view-todo.xml b/extra/webapps/todo/view-todo.xml new file mode 100644 index 0000000000..fea77c1189 --- /dev/null +++ b/extra/webapps/todo/view-todo.xml @@ -0,0 +1,23 @@ + + + + + View Item + + + + +
Summary:
Priority:
+ +
+ +
+ + Edit + | + + + + + + From 783d0d613d3389af5108ff917178bb0eaa2408dd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Apr 2008 07:09:01 -0500 Subject: [PATCH 746/886] Fix todo app --- extra/webapps/todo/todo.factor | 8 +++++--- extra/webapps/todo/todo.xml | 2 +- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 6277216eef..d8d9988109 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -7,7 +7,7 @@ http.server.forms http.server.templating.chloe http.server.boilerplate http.server.crud http.server.auth http.server.actions http.server.db http.server ; -IN: todo +IN: webapps.todo TUPLE: todo uid id priority summary description ; @@ -86,7 +86,7 @@ http.server.sessions.storage.db ; : test-db "todo.db" resource-path sqlite-db ; : ( -- responder ) - + users-in-db >>users allow-registration @@ -108,4 +108,6 @@ http.server.sessions.storage.db ; init-sessions-table ] with-db - main-responder set-global ; + + "todo" add-responder + main-responder set-global ; diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index a76ed2730f..81a5d3a425 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -8,7 +8,7 @@
List Items - | New Items + | Add Item | Edit Profile From defc1cfae97329b0aade66049093235a32485601 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 15 Apr 2008 21:55:26 -0500 Subject: [PATCH 747/886] fix sql --- extra/db/sql/sql-tests.factor | 2 +- extra/db/sql/sql.factor | 34 +++++++++++++++++----------------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/extra/db/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor index 488026fcc7..db69d71a84 100644 --- a/extra/db/sql/sql-tests.factor +++ b/extra/db/sql/sql-tests.factor @@ -28,7 +28,7 @@ TUPLE: person name age ; { select { columns "salary" } { from "staff" } - { where { "branchno" "b003" } } + { where { "branchno" = "b003" } } } } { "branchno" > 3 } } diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor index 26e8429efd..b0ec7aaf34 100755 --- a/extra/db/sql/sql.factor +++ b/extra/db/sql/sql.factor @@ -27,23 +27,23 @@ DEFER: sql% : 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 [ break "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 ; From 457644a07c99f3f228f8ced24ae5b4b2de2a8fa4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Apr 2008 22:03:40 -0500 Subject: [PATCH 748/886] Fix farkup bug --- extra/farkup/farkup-tests.factor | 2 ++ extra/xmode/catalog/catalog.factor | 10 +++++++--- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor index 8dc590449e..7176486f8e 100755 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -61,3 +61,5 @@ IN: farkup.tests [ "

\"teh

" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test [ "

" ] [ "[[lol.com]]" convert-farkup ] unit-test [ "

haha

" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test + +[ ] [ "[{}]" convert-farkup drop ] unit-test diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor index 62f0f6ede3..22d3217ee6 100755 --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -36,9 +36,13 @@ TAGS> f \ modes set-global ; MEMO: (load-mode) ( name -- rule-sets ) - modes at mode-file - "extra/xmode/modes/" prepend - resource-path utf8 parse-mode ; + modes at [ + mode-file + "extra/xmode/modes/" prepend + resource-path utf8 parse-mode + ] [ + "text" (load-mode) + ] if* ; SYMBOL: rule-sets From f7590182ac51be1cdded983d5fedd03f27f9fbee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Apr 2008 22:03:50 -0500 Subject: [PATCH 749/886] Fix typo --- extra/webapps/todo/todo.css | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/webapps/todo/todo.css b/extra/webapps/todo/todo.css index f7a6cfa1a2..c2e8a7fd79 100644 --- a/extra/webapps/todo/todo.css +++ b/extra/webapps/todo/todo.css @@ -7,7 +7,7 @@ background-color: #f5f5f5; padding: 5px; font-size: 150%; - color: #000000;3 + color: #000000; } .link-button { From 361361a5560ec1ba8b68660b75ee9ee60a270045 Mon Sep 17 00:00:00 2001 From: James Cash Date: Fri, 11 Apr 2008 14:28:28 -0400 Subject: [PATCH 750/886] Adding deployment for Linux --- extra/tools/deploy/linux/authors.txt | 1 + extra/tools/deploy/linux/linux.factor | 31 +++++++++++++++++++++++++++ extra/tools/deploy/linux/summary.txt | 1 + extra/tools/deploy/linux/tags.txt | 1 + 4 files changed, 34 insertions(+) create mode 100644 extra/tools/deploy/linux/authors.txt create mode 100644 extra/tools/deploy/linux/linux.factor create mode 100644 extra/tools/deploy/linux/summary.txt create mode 100644 extra/tools/deploy/linux/tags.txt diff --git a/extra/tools/deploy/linux/authors.txt b/extra/tools/deploy/linux/authors.txt new file mode 100644 index 0000000000..4b7af4aac0 --- /dev/null +++ b/extra/tools/deploy/linux/authors.txt @@ -0,0 +1 @@ +James Cash diff --git a/extra/tools/deploy/linux/linux.factor b/extra/tools/deploy/linux/linux.factor new file mode 100644 index 0000000000..fdbb67ef15 --- /dev/null +++ b/extra/tools/deploy/linux/linux.factor @@ -0,0 +1,31 @@ +USING: io io.files io.backend kernel namespaces sequences +system tools.deploy.backend tools.deploy.config assocs +hashtables prettyprint ; +IN: tools.deploy.linux + +: copy-vm ( executable bundle-name -- vm ) + prepend-path "" append + vm over copy-file ; + +: copy-fonts ( name -- ) + "fonts/" resource-path swap copy-tree-into ; + +: create-app-dir ( vocab bundle-name -- vm ) + dup copy-fonts + copy-vm ; + +: image-name ( vocab bundle-name -- str ) + prepend-path ".image" append ; + +: bundle-name ( -- str ) + deploy-name get ; + +M: linux 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 write + ] bind + ] with-directory ; \ No newline at end of file diff --git a/extra/tools/deploy/linux/summary.txt b/extra/tools/deploy/linux/summary.txt new file mode 100644 index 0000000000..4e2e8fbac4 --- /dev/null +++ b/extra/tools/deploy/linux/summary.txt @@ -0,0 +1 @@ +Deploying minimal stand-alone Linux binaries diff --git a/extra/tools/deploy/linux/tags.txt b/extra/tools/deploy/linux/tags.txt new file mode 100644 index 0000000000..ef1aab0d0e --- /dev/null +++ b/extra/tools/deploy/linux/tags.txt @@ -0,0 +1 @@ +tools From e5c880fcc2b2d2b86b468156efaf73a62d81ee01 Mon Sep 17 00:00:00 2001 From: James Cash Date: Fri, 11 Apr 2008 14:38:18 -0400 Subject: [PATCH 751/886] Adding information to deploy-docs regarding deployment on Linux --- extra/tools/deploy/deploy-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/tools/deploy/deploy-docs.factor b/extra/tools/deploy/deploy-docs.factor index b225236249..ec9d933f8b 100755 --- a/extra/tools/deploy/deploy-docs.factor +++ b/extra/tools/deploy/deploy-docs.factor @@ -7,7 +7,7 @@ ARTICLE: "tools.deploy" "Application deployment" $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." +"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 Linux, 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 From bfbedfaac31f79515488a7aa8f45d4fcdbb73383 Mon Sep 17 00:00:00 2001 From: James Cash Date: Fri, 11 Apr 2008 14:38:47 -0400 Subject: [PATCH 752/886] Minor change to linux deployment, print instead of write --- extra/tools/deploy/linux/linux.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/tools/deploy/linux/linux.factor b/extra/tools/deploy/linux/linux.factor index fdbb67ef15..05cb0cddc1 100644 --- a/extra/tools/deploy/linux/linux.factor +++ b/extra/tools/deploy/linux/linux.factor @@ -1,3 +1,5 @@ +! 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 ; @@ -26,6 +28,6 @@ M: linux deploy* ( vocab -- ) [ bundle-name create-app-dir ] keep [ bundle-name image-name ] keep namespace make-deploy-image - bundle-name normalize-path [ "Binary deployed to " % % "." % ] "" make write + bundle-name normalize-path [ "Binary deployed to " % % "." % ] "" make print ] bind ] with-directory ; \ No newline at end of file From 9d5b65ff74283ac1add60f5be9da72e99c4e14d2 Mon Sep 17 00:00:00 2001 From: James Cash Date: Fri, 11 Apr 2008 18:08:25 -0400 Subject: [PATCH 753/886] Fixing deploy-docs --- extra/tools/deploy/deploy-docs.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/extra/tools/deploy/deploy-docs.factor b/extra/tools/deploy/deploy-docs.factor index ec9d933f8b..5135332955 100755 --- a/extra/tools/deploy/deploy-docs.factor +++ b/extra/tools/deploy/deploy-docs.factor @@ -7,7 +7,12 @@ ARTICLE: "tools.deploy" "Application deployment" $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" } ". On Linux, 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." +{ $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 Linux, 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 From 738a59ee45cd60af79520247594777b26796606a Mon Sep 17 00:00:00 2001 From: James Cash Date: Fri, 11 Apr 2008 22:17:59 -0400 Subject: [PATCH 754/886] Adding requisite require for linux deployment --- extra/tools/deploy/deploy.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor index 893b43844a..6a91fab798 100755 --- a/extra/tools/deploy/deploy.factor +++ b/extra/tools/deploy/deploy.factor @@ -7,3 +7,4 @@ IN: tools.deploy os macosx? [ "tools.deploy.macosx" require ] when os winnt? [ "tools.deploy.windows" require ] when +os linux? [ "tools.deploy.linux" require ] when \ No newline at end of file From 0426ca274dea4d1b215e654a58e1d01aeecdf162 Mon Sep 17 00:00:00 2001 From: James Cash Date: Fri, 11 Apr 2008 22:35:58 -0400 Subject: [PATCH 755/886] Refactoring common functions out of platform-specific deployment --- extra/tools/deploy/backend/backend.factor | 9 +++++++++ extra/tools/deploy/linux/linux.factor | 14 ++------------ extra/tools/deploy/macosx/macosx.factor | 11 ++--------- extra/tools/deploy/windows/windows.factor | 11 ++--------- 4 files changed, 15 insertions(+), 30 deletions(-) diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index b838654248..ee904105be 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -105,5 +105,14 @@ DEFER: ?make-staging-image : make-deploy-image ( vm image vocab config -- ) make-boot-image deploy-command-line run-factor ; + +: copy-vm ( executable bundle-name extension -- vm ) + [ prepend-path ] dip append vm over copy-file ; + +: copy-fonts ( name dir -- ) + "fonts/" resource-path swap append-path copy-tree-into ; + +: image-name ( vocab bundle-name -- str ) + prepend-path ".image" append ; HOOK: deploy* os ( vocab -- ) diff --git a/extra/tools/deploy/linux/linux.factor b/extra/tools/deploy/linux/linux.factor index 05cb0cddc1..a995d66cd8 100644 --- a/extra/tools/deploy/linux/linux.factor +++ b/extra/tools/deploy/linux/linux.factor @@ -4,20 +4,10 @@ USING: io io.files io.backend kernel namespaces sequences system tools.deploy.backend tools.deploy.config assocs hashtables prettyprint ; IN: tools.deploy.linux - -: copy-vm ( executable bundle-name -- vm ) - prepend-path "" append - vm over copy-file ; - -: copy-fonts ( name -- ) - "fonts/" resource-path swap copy-tree-into ; : create-app-dir ( vocab bundle-name -- vm ) - dup copy-fonts - copy-vm ; - -: image-name ( vocab bundle-name -- str ) - prepend-path ".image" append ; + dup "" copy-fonts + "" copy-vm ; : bundle-name ( -- str ) deploy-name get ; diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 3121866d94..ca710e9d28 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -14,13 +14,6 @@ IN: tools.deploy.macosx bundle-dir over append-path -rot "Contents" prepend-path append-path copy-tree ; -: copy-vm ( executable bundle-name -- vm ) - "Contents/MacOS/" append-path prepend-path vm over copy-file ; - -: copy-fonts ( name -- ) - "fonts/" resource-path - swap "Contents/Resources/" append-path copy-tree-into ; - : app-plist ( executable bundle-name -- assoc ) [ "6.0" "CFBundleInfoDictionaryVersion" set @@ -40,8 +33,8 @@ IN: tools.deploy.macosx : 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 ; + dup "Contents/Resources/" copy-fonts + 2dup create-app-plist "Contents/MacOS/" append-path "" copy-vm ; : deploy.app-image ( vocab bundle-name -- str ) [ % "/Contents/Resources/" % % ".image" % ] "" make ; diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor index 68b106663c..5fc3e92c2b 100755 --- a/extra/tools/deploy/windows/windows.factor +++ b/extra/tools/deploy/windows/windows.factor @@ -5,13 +5,6 @@ tools.deploy.backend tools.deploy.config assocs hashtables prettyprint windows.shell32 windows.user32 ; IN: tools.deploy.windows -: copy-vm ( executable bundle-name -- vm ) - prepend-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 @@ -19,8 +12,8 @@ IN: tools.deploy.windows : create-exe-dir ( vocab bundle-name -- vm ) dup copy-dlls - dup copy-fonts - copy-vm ; + dup "" copy-fonts + ".exe" copy-vm ; : image-name ( vocab bundle-name -- str ) prepend-path ".image" append ; From c99b76b2f690c5736cba6dfbe8e7263b5851a58f Mon Sep 17 00:00:00 2001 From: James Cash Date: Fri, 11 Apr 2008 23:24:35 -0400 Subject: [PATCH 756/886] Got copy-fonts working properly (on Linux, at least) --- extra/tools/deploy/backend/backend.factor | 2 +- extra/tools/deploy/linux/linux.factor | 5 ++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index ee904105be..e8ca00cc8d 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -110,7 +110,7 @@ DEFER: ?make-staging-image [ prepend-path ] dip append vm over copy-file ; : copy-fonts ( name dir -- ) - "fonts/" resource-path swap append-path copy-tree-into ; + append-path "fonts/" resource-path swap copy-tree-into ; : image-name ( vocab bundle-name -- str ) prepend-path ".image" append ; diff --git a/extra/tools/deploy/linux/linux.factor b/extra/tools/deploy/linux/linux.factor index a995d66cd8..5f3d41c443 100644 --- a/extra/tools/deploy/linux/linux.factor +++ b/extra/tools/deploy/linux/linux.factor @@ -1,8 +1,7 @@ ! 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 ; +USING: io io.files io.backend kernel namespaces sequences system tools.deploy.backend +tools.deploy.config assocs hashtables prettyprint ; IN: tools.deploy.linux : create-app-dir ( vocab bundle-name -- vm ) From d7ddf9ad4276f271f372b3e5c18b53f70d47fc08 Mon Sep 17 00:00:00 2001 From: James Cash Date: Fri, 11 Apr 2008 23:25:53 -0400 Subject: [PATCH 757/886] Factor image-name out of windows deployment --- extra/tools/deploy/windows/windows.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor index 5fc3e92c2b..4f6527a4ce 100755 --- a/extra/tools/deploy/windows/windows.factor +++ b/extra/tools/deploy/windows/windows.factor @@ -15,9 +15,6 @@ IN: tools.deploy.windows dup "" copy-fonts ".exe" copy-vm ; -: image-name ( vocab bundle-name -- str ) - prepend-path ".image" append ; - M: winnt deploy* "." resource-path [ dup deploy-config [ From dca8d463beb1a6d7e9a3ce3891aead0e976cc12c Mon Sep 17 00:00:00 2001 From: James Cash Date: Sat, 12 Apr 2008 00:09:57 -0400 Subject: [PATCH 758/886] Minor moving stuff around in files --- extra/tools/deploy/backend/backend.factor | 18 +++++++++--------- extra/tools/deploy/linux/linux.factor | 5 +++-- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index e8ca00cc8d..d4fbf1de78 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -8,6 +8,15 @@ debugger io.streams.c io.streams.duplex io.files io.backend 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 @@ -105,14 +114,5 @@ DEFER: ?make-staging-image : make-deploy-image ( vm image vocab config -- ) make-boot-image deploy-command-line run-factor ; - -: 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 ; HOOK: deploy* os ( vocab -- ) diff --git a/extra/tools/deploy/linux/linux.factor b/extra/tools/deploy/linux/linux.factor index 5f3d41c443..a995d66cd8 100644 --- a/extra/tools/deploy/linux/linux.factor +++ b/extra/tools/deploy/linux/linux.factor @@ -1,7 +1,8 @@ ! 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 ; +USING: io io.files io.backend kernel namespaces sequences +system tools.deploy.backend tools.deploy.config assocs +hashtables prettyprint ; IN: tools.deploy.linux : create-app-dir ( vocab bundle-name -- vm ) From ef29f46537443d1c2b50a2f70a1f596833ce8490 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 13 Apr 2008 00:27:59 -0400 Subject: [PATCH 759/886] Changing names for linux deployment to unix --- extra/tools/deploy/deploy-docs.factor | 2 +- extra/tools/deploy/deploy.factor | 2 +- extra/tools/deploy/linux/summary.txt | 1 - extra/tools/deploy/{linux => unix}/authors.txt | 0 extra/tools/deploy/unix/summary.txt | 1 + extra/tools/deploy/{linux => unix}/tags.txt | 0 extra/tools/deploy/{linux/linux.factor => unix/unix.factor} | 0 7 files changed, 3 insertions(+), 3 deletions(-) delete mode 100644 extra/tools/deploy/linux/summary.txt rename extra/tools/deploy/{linux => unix}/authors.txt (100%) create mode 100644 extra/tools/deploy/unix/summary.txt rename extra/tools/deploy/{linux => unix}/tags.txt (100%) rename extra/tools/deploy/{linux/linux.factor => unix/unix.factor} (100%) diff --git a/extra/tools/deploy/deploy-docs.factor b/extra/tools/deploy/deploy-docs.factor index 5135332955..eccb3982c7 100755 --- a/extra/tools/deploy/deploy-docs.factor +++ b/extra/tools/deploy/deploy-docs.factor @@ -10,7 +10,7 @@ $nl { $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 Linux, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui" } "." } + { "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 diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor index 6a91fab798..bbeadc40cd 100755 --- a/extra/tools/deploy/deploy.factor +++ b/extra/tools/deploy/deploy.factor @@ -7,4 +7,4 @@ IN: tools.deploy os macosx? [ "tools.deploy.macosx" require ] when os winnt? [ "tools.deploy.windows" require ] when -os linux? [ "tools.deploy.linux" require ] when \ No newline at end of file +os unix? [ "tools.deploy.unix" require ] when \ No newline at end of file diff --git a/extra/tools/deploy/linux/summary.txt b/extra/tools/deploy/linux/summary.txt deleted file mode 100644 index 4e2e8fbac4..0000000000 --- a/extra/tools/deploy/linux/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Deploying minimal stand-alone Linux binaries diff --git a/extra/tools/deploy/linux/authors.txt b/extra/tools/deploy/unix/authors.txt similarity index 100% rename from extra/tools/deploy/linux/authors.txt rename to extra/tools/deploy/unix/authors.txt diff --git a/extra/tools/deploy/unix/summary.txt b/extra/tools/deploy/unix/summary.txt new file mode 100644 index 0000000000..7cd80c5e35 --- /dev/null +++ b/extra/tools/deploy/unix/summary.txt @@ -0,0 +1 @@ +Deploying minimal stand-alone binaries on *nix-like systems diff --git a/extra/tools/deploy/linux/tags.txt b/extra/tools/deploy/unix/tags.txt similarity index 100% rename from extra/tools/deploy/linux/tags.txt rename to extra/tools/deploy/unix/tags.txt diff --git a/extra/tools/deploy/linux/linux.factor b/extra/tools/deploy/unix/unix.factor similarity index 100% rename from extra/tools/deploy/linux/linux.factor rename to extra/tools/deploy/unix/unix.factor From aae907d5e1a20027fa06794f06aa480b38a69646 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Apr 2008 23:36:27 -0500 Subject: [PATCH 760/886] Fix problem with xml prologue showing up several times --- extra/http/http.factor | 18 +++---- extra/http/server/auth/login/login.factor | 25 ++-------- .../server/boilerplate/boilerplate.factor | 15 ++++-- .../server/components/components-tests.factor | 10 ++-- .../http/server/components/components.factor | 35 ++++++++++++++ extra/http/server/crud/crud.factor | 19 ++------ extra/http/server/forms/forms.factor | 48 +++++++++++-------- .../http/server/templating/chloe/chloe.factor | 18 ++++--- .../http/server/templating/fhtml/fhtml.factor | 2 + .../http/server/templating/templating.factor | 6 ++- extra/webapps/todo/todo.factor | 2 +- 11 files changed, 119 insertions(+), 79 deletions(-) diff --git a/extra/http/http.factor b/extra/http/http.factor index c25ae5590d..9e31855e53 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -394,16 +394,18 @@ body ; [ unparse-cookies "set-cookie" pick set-at ] when* write-header ; -: body>quot ( body -- quot ) - { - { [ dup not ] [ drop [ ] ] } - { [ dup string? ] [ [ write ] curry ] } - { [ dup callable? ] [ ] } - [ [ stdio get stream-copy ] curry ] - } cond ; +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>> body>quot call ; + dup body>> write-response-body* ; M: response write-response ( respose -- ) write-response-version diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 888234cc96..b0cc0c21d1 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -68,10 +68,7 @@ M: user-saver dispose [ blank-values ] >>init - [ - "text/html" - [ form edit-form ] >>body - ] >>display + [ form edit-form ] >>display [ blank-values @@ -120,10 +117,7 @@ SYMBOL: user-exists? [ blank-values ] >>init - [ - "text/html" - [ form edit-form ] >>body - ] >>display + [ form edit-form ] >>display [ blank-values @@ -174,10 +168,7 @@ SYMBOL: previous-page dup email>> "email" set-value ] >>init - [ - "text/html" - [ form edit-form ] >>body - ] >>display + [ form edit-form ] >>display [ blank-values @@ -262,10 +253,7 @@ SYMBOL: lost-password-from [ blank-values ] >>init - [ - "text/html" - [ form edit-form ] >>body - ] >>display + [ form edit-form ] >>display [ blank-values @@ -314,10 +302,7 @@ SYMBOL: lost-password-from ] H{ } make-assoc values set ] >>init - [ - "text/html" - [ edit-form ] >>body - ] >>display + [ edit-form ] >>display [ blank-values diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor index 2bd6eee340..4e847cff70 100644 --- a/extra/http/server/boilerplate/boilerplate.factor +++ b/extra/http/server/boilerplate/boilerplate.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces boxes sequences strings io io.streams.string +http http.server http.server.templating ; IN: http.server.boilerplate @@ -27,6 +28,8 @@ SYMBOL: style : write-style ( -- ) style get >string write ; +SYMBOL: nested-template? + SYMBOL: next-template : call-next-template ( -- ) @@ -39,9 +42,15 @@ M: f call-template drop call-next-template ; title get [ title set ] unless style get [ SBUF" " clone style set ] unless - swap with-string-writer next-template set - - call-template + [ + [ + nested-template? on + write-response-body* + ] with-string-writer + next-template set + ] + [ call-template ] + bi* ] with-scope ; inline M: boilerplate call-responder diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor index 29cfa1de8b..6d3a048ac4 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -1,12 +1,10 @@ IN: http.server.components.tests USING: http.server.components http.server.forms http.server.validators namespaces tools.test kernel accessors -tuple-syntax mirrors http.server.actions -http.server.templating.fhtml +tuple-syntax mirrors +http http.server.actions http.server.templating.fhtml io.streams.string io.streams.null ; -\ render-edit must-infer - validation-failed? off [ 3 ] [ "3" "n" validate ] unit-test @@ -65,9 +63,9 @@ TUPLE: test-tuple text number more-text ; "hi" >>default add-field ; -[ ] [ values set view-form ] unit-test +[ ] [ values set view-form write-response-body drop ] unit-test -[ ] [ values set edit-form ] unit-test +[ ] [ values set edit-form write-response-body drop ] unit-test [ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [ from-tuple diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 3ab0bdd770..50353c6b87 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -7,9 +7,12 @@ continuations math ; 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 @@ -235,3 +238,35 @@ TUPLE: text < string ; : ( id -- component ) text new-text ; + +! List components +SYMBOL: +plain+ +SYMBOL: +ordered+ +SYMBOL: +unordered+ + +TUPLE: list-renderer component type ; + +C: list-renderer + +: render-list ( value component -- ) + [ render-summary* ] curry each ; + +: render-ordered-list ( value component -- ) + [
  • render-summary*
    • ] curry each ; + +: render-unordered-list ( value component -- ) + [
  • render-summary*
    • ] curry each ; + +M: list-renderer render-view* + [ component>> ] [ type>> ] bi { + { +plain+ [ render-list ] } + { +ordered+ [
      render-ordered-list
    ] } + { +unordered+ [
      render-unordered-list
    ] } + } case ; + +TUPLE: list < component ; + +: ( id component type -- list ) + list swap new-component ; + +M: list component-string drop ; diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor index cf9771e15f..65de881adb 100755 --- a/extra/http/server/crud/crud.factor +++ b/extra/http/server/crud/crud.factor @@ -15,10 +15,7 @@ IN: http.server.crud [ "id" get ctor call select-tuple from-tuple ] >>init - [ - "text/html" - [ form view-form ] >>body - ] >>display ; + [ form view-form ] >>display ; : ( id next -- response ) swap number>string "id" associate ; @@ -36,10 +33,7 @@ IN: http.server.crud if ] >>init - [ - "text/html" - [ form edit-form ] >>body - ] >>display + [ form edit-form ] >>display [ f ctor call from-tuple @@ -65,12 +59,9 @@ IN: http.server.crud :: ( form ctor -- action ) [ - "text/html" - [ - blank-values + blank-values - f ctor call select-tuples "list" set-value + f ctor call select-tuples "list" set-value - form view-form - ] >>body + form view-form ] >>display ; diff --git a/extra/http/server/forms/forms.factor b/extra/http/server/forms/forms.factor index 2c2b673f83..1b4f7f4d37 100644 --- a/extra/http/server/forms/forms.factor +++ b/extra/http/server/forms/forms.factor @@ -1,4 +1,7 @@ +! 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 @@ -17,8 +20,11 @@ M: form init V{ } clone >>components ; : add-field ( form component -- form ) dup id>> pick components>> set-at ; +: set-components ( form -- ) + components>> components set ; + : with-form ( form quot -- ) - >r components>> components r> with-variable ; inline + [ [ set-components ] [ call ] bi* ] with-scope ; inline : set-defaults ( form -- ) [ @@ -29,14 +35,16 @@ M: form init V{ } clone >>components ; ] assoc-each ] with-form ; -: view-form ( form -- ) - dup view-template>> '[ , call-template ] with-form ; +: ( form template -- response ) + [ components>> components set ] + [ "text/html" swap >>body ] + bi* ; -: edit-form ( form -- ) - dup edit-template>> '[ , call-template ] with-form ; +: view-form ( form -- response ) + dup view-template>> ; -: summary-form ( form -- ) - dup summary-template>> '[ , call-template ] with-form ; +: edit-form ( form -- response ) + dup edit-template>> ; : validate-param ( id component -- ) [ [ params get at ] [ validate ] bi* ] @@ -52,19 +60,19 @@ M: form init V{ } clone >>components ; : validate-form ( form -- ) (validate-form) [ validation-failed ] when ; -! List components -TUPLE: list-renderer form ; +: render-form ( value form template -- ) + [ + [ from-tuple ] + [ set-components ] + [ call-template ] + tri* + ] with-scope ; -C: list-renderer +M: form render-summary* + dup summary-template>> render-form ; -M: list-renderer render-view* - form>> [ - [ >r from-tuple r> summary-form ] with-scope - ] curry each ; +M: form render-view* + dup view-template>> render-form ; -TUPLE: list < component ; - -: ( id form -- list ) - list swap new-component ; - -M: list component-string drop ; +M: form render-edit* + dup edit-template>> render-form ; diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/http/server/templating/chloe/chloe.factor index 9da153607f..06cf2936ce 100644 --- a/extra/http/server/templating/chloe/chloe.factor +++ b/extra/http/server/templating/chloe/chloe.factor @@ -156,13 +156,19 @@ SYMBOL: tags [ V{ } clone tags set - { - [ xml-prolog write-prolog ] - [ xml-before write-chunk ] - [ process-template ] - [ xml-after write-chunk ] - } cleave + 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 read-xml process-chloe ; + +INSTANCE: chloe template diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor index 237931dc34..1cba4b9b2e 100755 --- a/extra/http/server/templating/fhtml/fhtml.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -94,3 +94,5 @@ M: fhtml call-template ( filename -- ) [ serve-template ] "application/x-factor-server-page" pick special>> set-at ; + +INSTANCE: fhtml template diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index 378823e9d1..f69dd9bfe0 100644 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -1,9 +1,13 @@ USING: accessors kernel fry io.encodings.utf8 io.files -http.server ; +http http.server ; IN: http.server.templating +MIXIN: template + GENERIC: call-template ( template -- ) +M: template write-response-body* call-template ; + : template-convert ( template output -- ) utf8 [ call-template ] with-file-writer ; diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index d8d9988109..917b9bf7a7 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -53,7 +53,7 @@ todo "TODO" : ( -- form ) "todo-list" "todo-list" todo-template >>view-template - "list" + "list" +plain+ add-field ; TUPLE: todo-responder < dispatcher ; From 9f46b534e91523b79e118245ae6f6af76dccb81c Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Tue, 15 Apr 2008 01:00:37 -0700 Subject: [PATCH 761/886] export in random.blum-blum-shub --- extra/project-euler/164/164.factor | 2 +- extra/random/blum-blum-shub/blum-blum-shub.factor | 11 +++++------ 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/extra/project-euler/164/164.factor b/extra/project-euler/164/164.factor index 67397593bd..bf1f5dcf9b 100644 --- a/extra/project-euler/164/164.factor +++ b/extra/project-euler/164/164.factor @@ -30,4 +30,4 @@ IN: project-euler.164 PRIVATE> : euler164 ( -- n ) - init-table 19 [ next-table ] times values sum ; \ No newline at end of file + init-table 19 [ next-table ] times values sum ; diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor index db8fe540e5..e60990075c 100755 --- a/extra/random/blum-blum-shub/blum-blum-shub.factor +++ b/extra/random/blum-blum-shub/blum-blum-shub.factor @@ -12,17 +12,16 @@ TUPLE: blum-blum-shub x n ; : 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> + : ( numbits -- blum-blum-shub ) generate-bbs-primes * [ find-relative-prime ] keep blum-blum-shub boa ; -: next-bbs-bit ( bbs -- bit ) - [ [ x>> 2 ] [ n>> ] bi ^mod ] keep - over >>x drop 1 bitand ; - -PRIVATE> - M: blum-blum-shub random-32* ( bbs -- r ) 0 32 rot [ next-bbs-bit swap 1 shift bitor ] curry times ; From 8d0fdd365128dc62da34790f58eb67ee9eb52c5f Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Tue, 15 Apr 2008 18:04:30 -0700 Subject: [PATCH 762/886] Add project-euler solution no. 76 --- extra/project-euler/076/076.factor | 53 ++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) create mode 100644 extra/project-euler/076/076.factor diff --git a/extra/project-euler/076/076.factor b/extra/project-euler/076/076.factor new file mode 100644 index 0000000000..b09a2742c3 --- /dev/null +++ b/extra/project-euler/076/076.factor @@ -0,0 +1,53 @@ +! 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) + +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) ; From 2bdcba57319a12e5f5b2b619338b421420ab7776 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Tue, 15 Apr 2008 23:09:23 -0700 Subject: [PATCH 763/886] Add solution for project-euler.117 --- extra/project-euler/117/117.factor | 42 ++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) create mode 100644 extra/project-euler/117/117.factor diff --git a/extra/project-euler/117/117.factor b/extra/project-euler/117/117.factor new file mode 100644 index 0000000000..5056560a85 --- /dev/null +++ b/extra/project-euler/117/117.factor @@ -0,0 +1,42 @@ +! 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) + + + +: (euler117) ( n -- m ) + V{ 1 } clone tuck [ next ] curry times peek ; + +: euler117 ( -- m ) + 50 (euler117) ; From 303f9a34506b1c2a02c43681ce861fe93f2d3c1a Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Wed, 16 Apr 2008 00:04:05 -0700 Subject: [PATCH 764/886] Add project-euler.116 --- extra/project-euler/116/116.factor | 55 ++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) create mode 100644 extra/project-euler/116/116.factor diff --git a/extra/project-euler/116/116.factor b/extra/project-euler/116/116.factor new file mode 100644 index 0000000000..d48cdf175c --- /dev/null +++ b/extra/project-euler/116/116.factor @@ -0,0 +1,55 @@ +! 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 + + + +: (euler116) ( length -- permutations ) + 3 [1,b] [ ways ] with sigma ; + +: euler116 ( -- permutations ) + 50 (euler116) ; From 3483317cfb146f803b99416c28fb7cc45d1b31e1 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Wed, 16 Apr 2008 02:25:38 -0700 Subject: [PATCH 765/886] Add project-euler.150 --- extra/project-euler/150/150.factor | 46 ++++++++++++++++++++++++++++++ 1 file changed, 46 insertions(+) create mode 100644 extra/project-euler/150/150.factor diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor new file mode 100644 index 0000000000..3bd145d53c --- /dev/null +++ b/extra/project-euler/150/150.factor @@ -0,0 +1,46 @@ +USING: kernel math math.ranges math.parser sequences io locals namespaces ; + +IN: project-euler.150 + +: next-t ( t -- t' ) + 615949 * 797807 + 1 20 shift rem ; inline + +: next-s ( t -- s ) + 1 19 shift - ; inline + +: generate ( -- seq ) + 0 500500 [ drop next-t dup next-s ] map nip ; + +: start-index ( i -- n ) + dup 1- * 2/ ; inline + +: partial-sums ( seq -- seq ) + 0 [ + ] accumulate swap suffix ; inline + +: as-triangle ( i seq -- slices ) + swap [1,b] [ [ start-index dup ] keep + rot ] with map ; + +: sums-triangle ( -- seqs ) + 1000 generate as-triangle [ partial-sums ] map ; + +SYMBOL: best + +: check-best ( i -- ) + best [ min ] change ; inline + +:: (euler150) ( m -- n ) + [ [let | table [ sums-triangle ] | + 0 best set + m [| x | + x 1+ [| y | + 1000 x - [| z | + x z + table nth + [ y z + 1+ swap nth ] [ y swap nth ] bi - + ] map partial-sums infimum check-best + ] each + ] each + ] + best get ] with-scope ; + +: euler150 ( -- n ) + 1000 (euler150) ; From a25c7e1842161a8ed42407f8d3ef589a35e8546c Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Wed, 16 Apr 2008 10:30:03 -0700 Subject: [PATCH 766/886] Improve project-euler.150 --- extra/project-euler/150/150.factor | 56 ++++++++++++++---------------- 1 file changed, 27 insertions(+), 29 deletions(-) diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor index 3bd145d53c..5b22a1b9f6 100644 --- a/extra/project-euler/150/150.factor +++ b/extra/project-euler/150/150.factor @@ -1,46 +1,44 @@ -USING: kernel math math.ranges math.parser sequences io locals namespaces ; - +! Copyright (c) 2008 Eric Mertens +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math sequences locals ; IN: project-euler.150 -: next-t ( t -- t' ) - 615949 * 797807 + 1 20 shift rem ; inline + ] with map ; +: generate ( n quot -- seq ) + [ drop ] swap compose map ; inline -: sums-triangle ( -- seqs ) - 1000 generate as-triangle [ partial-sums ] map ; +: map-infimum ( seq quot -- min ) + [ min ] compose 0 swap reduce ; inline -SYMBOL: best -: check-best ( i -- ) - best [ min ] change ; inline +! triangle generator functions + +: next ( t -- new-t s ) + 615949 * 797807 + 1 20 shift mod dup 1 19 shift - ; inline + +: sums-triangle ( -- seq ) + 0 1000 [ 1+ [ next ] generate partial-sums ] map nip ; + +PRIVATE> :: (euler150) ( m -- n ) - [ [let | table [ sums-triangle ] | - 0 best set + [let | table [ sums-triangle ] | m [| x | - x 1+ [| y | - 1000 x - [| z | + x 1+ [| y | + m x - [| z | x z + table nth - [ y z + 1+ swap nth ] [ y swap nth ] bi - - ] map partial-sums infimum check-best - ] each - ] each - ] - best get ] with-scope ; + [ y z + 1+ swap nth ] + [ y swap nth ] bi - + ] map partial-sums infimum + ] map-infimum + ] map-infimum + ] ; : euler150 ( -- n ) 1000 (euler150) ; From 9589c5359a8a0c0109cfe6df24e978a001b16b0a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 17 Apr 2008 03:03:00 -0500 Subject: [PATCH 767/886] Remove commented-out code --- core/bootstrap/stage2.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index ca90587ea9..dfd2e4be6f 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -27,10 +27,6 @@ SYMBOL: bootstrap-time diff [ "bootstrap." prepend require ] each ; -! : compile-remaining ( -- ) -! "Compiling remaining words..." print flush -! vocabs [ words [ compiled? not ] subset compile ] each ; - : count-words ( pred -- ) all-words swap subset length number>string write ; From 4eb4542431dc569e1488794f0d4f19a041fcd6c0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 17 Apr 2008 03:03:22 -0500 Subject: [PATCH 768/886] Add failing unit test --- core/compiler/tests/templates.factor | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 845189ce2c..14d75cdc03 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -3,7 +3,7 @@ USING: arrays compiler kernel kernel.private math 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! @@ -246,3 +246,12 @@ TUPLE: my-tuple ; } 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 From b2a3bfa4668163d02a093b6fef5c88f8a4720bf2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 17 Apr 2008 03:03:33 -0500 Subject: [PATCH 769/886] Fix regexp parsing word bug --- extra/regexp/regexp-tests.factor | 7 +++++++ extra/regexp/regexp.factor | 9 +++++---- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/extra/regexp/regexp-tests.factor b/extra/regexp/regexp-tests.factor index 5a6b0bdfac..e9433c6c64 100755 --- a/extra/regexp/regexp-tests.factor +++ b/extra/regexp/regexp-tests.factor @@ -226,3 +226,10 @@ IN: regexp-tests [ t ] [ "s@f" "[a-z.-]@[a-z]" f matches? ] unit-test [ f ] [ "a" "[a-z.-]@[a-z]" f matches? ] unit-test [ t ] [ ".o" "\\.[a-z]" f matches? ] unit-test + +! Bug in parsing word +[ t ] [ + "a" + R' a' + matches? +] unit-test diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index 6b344ad140..d517db09fe 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -290,10 +290,11 @@ TUPLE: regexp source parser ignore-case? ; } case ; : parse-regexp ( accum end -- accum ) - lexer get dup skip-blank [ - [ index* dup 1+ swap ] 2keep swapd subseq swap - ] change-lexer-column - lexer get (parse-token) parse-options 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 + parsed ; : R! CHAR: ! parse-regexp ; parsing : R" CHAR: " parse-regexp ; parsing From b4ce5c93e81ad0f59c9ad55c5a84bb01af4cac39 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 17 Apr 2008 03:05:36 -0500 Subject: [PATCH 770/886] More efficient locals --- core/inference/backend/backend.factor | 40 ++++---- core/inference/known-words/known-words.factor | 8 +- extra/locals/backend/backend-tests.factor | 38 ++++++++ extra/locals/backend/backend.factor | 37 +++++++ extra/locals/locals-tests.factor | 2 + extra/locals/locals.factor | 96 ++++++++----------- 6 files changed, 142 insertions(+), 79 deletions(-) create mode 100644 extra/locals/backend/backend-tests.factor create mode 100644 extra/locals/backend/backend.factor diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index cf40944d1d..e0cc1a5839 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -15,7 +15,7 @@ GENERIC: inline? ( word -- ? ) M: method-body inline? "method-generic" word-prop inline? ; -M: tuple-dispatch-engine-word inline? +M: engine-word inline? "tuple-dispatch-generic" word-prop inline? ; M: word inline? @@ -130,25 +130,27 @@ TUPLE: too-many->r ; 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 ; @@ -199,18 +201,18 @@ M: object constructor drop f ; dup infer-uncurry constructor [ peek-d reify-curry - infer->r + 1 infer->r peek-d reify-curry - infer-r> + 1 infer-r> 2 1 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 ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 453e2460b0..2e471420da 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -54,9 +54,9 @@ IN: inference.known-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 @@ -81,8 +81,8 @@ M: curried infer-call 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 ; diff --git a/extra/locals/backend/backend-tests.factor b/extra/locals/backend/backend-tests.factor new file mode 100644 index 0000000000..41caa87fae --- /dev/null +++ b/extra/locals/backend/backend-tests.factor @@ -0,0 +1,38 @@ +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 diff --git a/extra/locals/backend/backend.factor b/extra/locals/backend/backend.factor new file mode 100644 index 0000000000..a51216b079 --- /dev/null +++ b/extra/locals/backend/backend.factor @@ -0,0 +1,37 @@ +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 infer-shuffle ] + [ infer->r ] + bi +] "infer" set-word-prop + +\ get-local [ + pop-literal nip + [ infer-r> ] + [ dup 0 prefix infer-shuffle ] + [ infer->r ] + tri +] "infer" set-word-prop + +\ drop-locals [ + pop-literal nip + [ infer-r> ] + [ { } infer-shuffle ] bi +] "infer" set-word-prop diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index 4ee9b48bb7..c13be40c8f 100755 --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -82,6 +82,8 @@ IN: locals.tests 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 diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 2b0c61cc89..be73f1db88 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -4,7 +4,8 @@ USING: kernel namespaces sequences sequences.private assocs math inference.transforms parser words quotations debugger macros arrays macros splitting combinators prettyprint.backend definitions prettyprint hashtables prettyprint.sections sets -sequences.private effects generic compiler.units accessors ; +sequences.private effects generic compiler.units accessors +locals.backend ; IN: locals ! Inspired by @@ -56,95 +57,80 @@ TUPLE: quote local ; C: 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> ] concat [ dup ] append - swap [ swap >r ] 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 ) + dup [ local-reader? ] contains? [ + [ + local-reader? [ 1array >r ] [ >r ] ? + ] map concat + ] [ + length [ load-locals ] curry >quotation + ] if ; -: load-locals ( quot args -- quot ) - nip [ load-local ] map concat ; - -: drop-locals ( args -- args quot ) - dup length [ r> drop ] 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 suffix ] + [ 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 suffix ] } - { [ dup lexical? ] [ suffix ] } - { [ dup quote? ] [ quote-local suffix ] } - { [ 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: object free-vars* drop ; -M: quotation free-vars { } [ add-if-free ] reduce ; +M: quotation free-vars* [ add-if-free ] each ; -M: lambda free-vars - dup vars>> swap body>> free-vars diff ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! lambda-rewrite -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +M: lambda free-vars* + [ vars>> ] [ body>> ] bi free-vars diff % ; GENERIC: lambda-rewrite* ( obj -- ) @@ -172,8 +158,8 @@ M: lambda block-vars vars>> ; M: lambda block-body body>> ; M: lambda local-rewrite* - dup vars>> swap body>> - [ local-rewrite* \ call , ] [ ] make , ; + [ vars>> ] [ body>> ] bi + [ [ local-rewrite* ] each ] [ ] make , ; M: block lambda-rewrite* #! Turn free variables into bound variables, curry them @@ -188,8 +174,6 @@ M: object lambda-rewrite* , ; M: object local-rewrite* , ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : make-local ( name -- word ) "!" ?tail [ From 91e516853aa161bc025412053aa9cc003ad2c562 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 17 Apr 2008 03:06:55 -0500 Subject: [PATCH 771/886] Generate branches in reverse order --- core/cpu/architecture/architecture.factor | 2 +- core/cpu/ppc/architecture/architecture.factor | 4 ++-- core/cpu/ppc/intrinsics/intrinsics.factor | 20 +++++++++---------- core/cpu/x86/32/32.factor | 2 +- core/cpu/x86/architecture/architecture.factor | 8 ++++---- core/cpu/x86/intrinsics/intrinsics.factor | 10 +++++----- core/cpu/x86/sse2/sse2.factor | 10 +++++----- core/generator/generator.factor | 14 ++++++------- 8 files changed, 35 insertions(+), 35 deletions(-) diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 65d1763ea8..8c9db6c7e8 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -56,7 +56,7 @@ HOOK: %call cpu ( word -- ) HOOK: %jump-label cpu ( label -- ) ! Test if vreg is 'f' or not -HOOK: %jump-t cpu ( label -- ) +HOOK: %jump-f cpu ( label -- ) HOOK: %dispatch cpu ( -- ) diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 09ffead029..5bc6d0144d 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -106,8 +106,8 @@ M: ppc %call ( label -- ) BL ; M: ppc %jump-label ( label -- ) B ; -M: ppc %jump-t ( label -- ) - 0 "flag" operand f v>operand CMPI BNE ; +M: ppc %jump-f ( label -- ) + 0 "flag" operand f v>operand CMPI BE ; M: ppc %dispatch ( -- ) [ diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index d092473960..34e9900893 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -217,11 +217,11 @@ IN: cpu.ppc.intrinsics 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 @@ -356,11 +356,11 @@ IN: cpu.ppc.intrinsics { { 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 diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index cc3fceff23..f460dcfcf6 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -267,7 +267,7 @@ os windows? [ EDX 26 SHR EDX 1 AND { EAX EBX ECX EDX } [ POP ] each - JNE + JE ] { } define-if-intrinsic "-no-sse2" cli-args member? [ diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index 25bb3c6e07..4c2c506e9a 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -47,13 +47,13 @@ M: x86 stack-frame ( n -- i ) 3 cells + 16 align cell - ; M: x86 %save-word-xt ( -- ) - xt-reg 0 MOV rc-absolute-cell rel-this ; + temp-reg v>operand 0 MOV rc-absolute-cell rel-this ; : factor-area-size 4 cells ; M: x86 %prologue ( n -- ) dup cell + PUSH - xt-reg PUSH + temp-reg v>operand PUSH stack-reg swap 2 cells - SUB ; M: x86 %epilogue ( n -- ) @@ -76,8 +76,8 @@ M: x86 %call ( label -- ) CALL ; M: x86 %jump-label ( label -- ) JMP ; -M: x86 %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 - ; diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index 80a786c9fa..c48f33b765 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -212,11 +212,11 @@ IN: cpu.x86.intrinsics 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 diff --git a/core/cpu/x86/sse2/sse2.factor b/core/cpu/x86/sse2/sse2.factor index 9c477b4132..fb96649753 100755 --- a/core/cpu/x86/sse2/sse2.factor +++ b/core/cpu/x86/sse2/sse2.factor @@ -27,11 +27,11 @@ IN: cpu.x86.sse2 { { 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 diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 919e89d3c8..4eb2c0fe4e 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -131,14 +131,14 @@ M: #loop generate-node : generate-if ( node label -- next )