From 67c9e2f63192b8145a703bdf6d6dcc2d2e1079dd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 16 Mar 2008 15:17:11 -0500 Subject: [PATCH 01/72] 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 02/72] 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 03/72] 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 04/72] 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 05/72] 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 06/72] 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 07/72] 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 08/72] 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 09/72] 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 10/72] 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 11/72] 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 12/72] 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 13/72] 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 14/72] 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 15/72] 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 16/72] 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 17/72] 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 18/72] 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 19/72] 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 20/72] 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 21/72] 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 22/72] 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 23/72] 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 24/72] 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 25/72] 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 26/72] 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 27/72] 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 28/72] 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 29/72] 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 30/72] 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 31/72] 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 32/72] 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 33/72] 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 34/72] 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 35/72] -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 36/72] 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 37/72] 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 38/72] 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 39/72] 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 40/72] 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 41/72] 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 42/72] 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 43/72] 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 a14854520da6b9c41ee0f0aeb9235fa9d894129a Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 21 Mar 2008 03:05:21 +1300 Subject: [PATCH 44/72] 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 9584be29817d738b6f7054f7e685de12068a325f Mon Sep 17 00:00:00 2001 From: sheeple Date: Thu, 20 Mar 2008 18:02:19 -0500 Subject: [PATCH 45/72] 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 46/72] 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 47/72] 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 48/72] 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 49/72] 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 50/72] 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 51/72] 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 52/72] 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 53/72] 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 54/72] 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 55/72] 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 56/72] 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 57/72] 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 58/72] 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 e60d8a49c1e676d357f7d84aa4cc8c3a56734342 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 21 Mar 2008 15:36:49 -0500 Subject: [PATCH 59/72] 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 8d7ccf2596bfca71ed9d50849a70e4cc371d7f0a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 21 Mar 2008 17:48:01 -0500 Subject: [PATCH 60/72] 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 598127c0e2d1ca6d72fdbf0551c76ff4a0a306a7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Mar 2008 12:02:10 -0500 Subject: [PATCH 61/72] 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 62/72] 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 63/72] 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 64/72] 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 65/72] 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 66/72] 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 67/72] 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 68/72] 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 69/72] 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 70/72] 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 71/72] 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 72/72] 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