From d2079c50fbfb4abf172271430e748405a3861a17 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 2 Feb 2008 12:23:51 -0600 Subject: [PATCH 01/62] Fixing stupid splay trees bug --- extra/trees/splay/splay.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor index 4fe6fe79a5..2fca5eca95 100644 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -7,7 +7,7 @@ IN: trees.splay TUPLE: splay ; : ( -- splay-tree ) - splay construct-tree ; + \ splay construct-tree ; INSTANCE: splay tree-mixin From e2c20d23a4856580e1d8eabf2b57a8d6b5d78d0d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 11:06:11 -0600 Subject: [PATCH 02/62] add missing use fix dll path on windows --- extra/ogg/theora/theora.factor | 2 +- extra/ogg/vorbis/vorbis.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/ogg/theora/theora.factor b/extra/ogg/theora/theora.factor index 0d9748a6f3..48b61b41a3 100644 --- a/extra/ogg/theora/theora.factor +++ b/extra/ogg/theora/theora.factor @@ -6,7 +6,7 @@ IN: ogg.theora << "theora" { - { [ win32? ] [ "libtheora.dll" ] } + { [ win32? ] [ "theora.dll" ] } { [ macosx? ] [ "libtheora.0.dylib" ] } { [ unix? ] [ "libtheora.so" ] } } cond "cdecl" add-library diff --git a/extra/ogg/vorbis/vorbis.factor b/extra/ogg/vorbis/vorbis.factor index 26e917ebf4..170d0ea6ef 100644 --- a/extra/ogg/vorbis/vorbis.factor +++ b/extra/ogg/vorbis/vorbis.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel system combinators alien alien.syntax ; +USING: kernel system combinators alien alien.syntax ogg ; IN: ogg.vorbis << From bc3bf6b2b4ede72aa4332dd3f7b98cd85f836756 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 11:45:53 -0600 Subject: [PATCH 03/62] make factor compile on win64 --- Makefile | 6 +++++- vm/Config.windows.nt.x86.32 | 1 + vm/Config.windows.nt.x86.64 | 6 ++++-- vm/os-windows-nt.32.h | 2 ++ vm/os-windows-nt.64.h | 2 ++ vm/os-windows-nt.c | 10 +++++----- vm/platform.h | 9 +++++++-- 7 files changed, 26 insertions(+), 10 deletions(-) create mode 100644 vm/os-windows-nt.32.h create mode 100644 vm/os-windows-nt.64.h diff --git a/Makefile b/Makefile index aad7fe90eb..bd1bf16c74 100755 --- a/Makefile +++ b/Makefile @@ -65,6 +65,7 @@ default: @echo "solaris-x86-64" @echo "windows-ce-arm" @echo "windows-nt-x86-32" + @echo "windows-nt-x86-64" @echo "" @echo "Additional modifiers:" @echo "" @@ -125,6 +126,9 @@ solaris-x86-64: windows-nt-x86-32: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 +windows-nt-x86-64: + $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64 + windows-ce-arm: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm @@ -151,7 +155,7 @@ clean: rm -f factor*.dll libfactor*.* vm/resources.o: - windres vm/factor.rs vm/resources.o + $(WINDRES) vm/factor.rs vm/resources.o .c.o: $(CC) -c $(CFLAGS) -o $@ $< diff --git a/vm/Config.windows.nt.x86.32 b/vm/Config.windows.nt.x86.32 index 9a020a7bc1..603a7200ae 100644 --- a/vm/Config.windows.nt.x86.32 +++ b/vm/Config.windows.nt.x86.32 @@ -1,3 +1,4 @@ WINDRES=windres include vm/Config.windows.nt include vm/Config.x86.32 +#error "lolllll" diff --git a/vm/Config.windows.nt.x86.64 b/vm/Config.windows.nt.x86.64 index 1c30e64096..6d3865c2f4 100644 --- a/vm/Config.windows.nt.x86.64 +++ b/vm/Config.windows.nt.x86.64 @@ -1,4 +1,6 @@ -CC=/k/target/bin/x86_64-pc-mingw32-gcc +#WIN64_PATH=/k/MinGW/win64/bin +WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32 +CC=$(WIN64_PATH)-gcc.exe +WINDRES=$(WIN64_PATH)-windres.exe include vm/Config.windows.nt include vm/Config.x86.64 -WINDRES = /k/target/bin/windres diff --git a/vm/os-windows-nt.32.h b/vm/os-windows-nt.32.h new file mode 100644 index 0000000000..9b10671ba0 --- /dev/null +++ b/vm/os-windows-nt.32.h @@ -0,0 +1,2 @@ +#define ESP Esp +#define EIP Eip diff --git a/vm/os-windows-nt.64.h b/vm/os-windows-nt.64.h new file mode 100644 index 0000000000..1f61c2335f --- /dev/null +++ b/vm/os-windows-nt.64.h @@ -0,0 +1,2 @@ +#define ESP Rsp +#define EIP Rip diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index e356c2f674..3995b6a35a 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -57,26 +57,26 @@ long exception_handler(PEXCEPTION_POINTERS pe) PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord; CONTEXT *c = (CONTEXT*)pe->ContextRecord; - if(in_code_heap_p(c->Eip)) - signal_callstack_top = (void *)c->Esp; + if(in_code_heap_p(c->EIP)) + signal_callstack_top = (void *)c->ESP; else signal_callstack_top = NULL; if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) { signal_fault_addr = e->ExceptionInformation[1]; - c->Eip = (CELL)memory_signal_handler_impl; + c->EIP = (CELL)memory_signal_handler_impl; } else if(e->ExceptionCode == EXCEPTION_FLT_DIVIDE_BY_ZERO || e->ExceptionCode == EXCEPTION_INT_DIVIDE_BY_ZERO) { signal_number = ERROR_DIVIDE_BY_ZERO; - c->Eip = (CELL)divide_by_zero_signal_handler_impl; + c->EIP = (CELL)divide_by_zero_signal_handler_impl; } else { signal_number = 11; - c->Eip = (CELL)misc_signal_handler_impl; + c->EIP = (CELL)misc_signal_handler_impl; } return EXCEPTION_CONTINUE_EXECUTION; diff --git a/vm/platform.h b/vm/platform.h index b0641176bc..66f22bbf96 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -1,11 +1,11 @@ #if defined(__arm__) #define FACTOR_ARM +#elif defined(__amd64__) || defined(__x86_64__) + #define FACTOR_AMD64 #elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32) #define FACTOR_X86 #elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC) #define FACTOR_PPC -#elif defined(__amd64__) || defined(__x86_64__) - #define FACTOR_AMD64 #else #error "Unsupported architecture" #endif @@ -18,6 +18,11 @@ #endif #include "os-windows.h" + #if defined(FACTOR_AMD64) + #include "os-windows-nt.64.h" + #elif defined(FACTOR_X86) + #include "os-windows-nt.32.h" + #endif #else #include "os-unix.h" From 87d44252c59f0a7d967157b634f10dc83acce442 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 12:30:23 -0600 Subject: [PATCH 04/62] add more dlls to script --- misc/factor.sh | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/misc/factor.sh b/misc/factor.sh index 032b0b3184..02f4c4a542 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -233,6 +233,16 @@ maybe_download_dlls() { check_ret wget wget http://factorcode.org/dlls/zlib1.dll check_ret wget + wget http://factorcode.org/dlls/OpenAL32.dll + check_ret wget + wget http://factorcode.org/dlls/alut.dll + check_ret wget + wget http://factorcode.org/dlls/ogg.dll + check_ret wget + wget http://factorcode.org/dlls/theora.dll + check_ret wget + wget http://factorcode.org/dlls/vorbis.dll + check_ret wget chmod 777 *.dll check_ret chmod fi From c9a7f35e9ccb21e4e08ece6182c110defdb6d490 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 13:32:27 -0600 Subject: [PATCH 05/62] remove spurious db.sql --- extra/db/db.factor | 1 - extra/db/sqlite/sqlite-tests.factor | 2 +- extra/db/sqlite/sqlite.factor | 2 +- 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index b765924cd6..1c287cd871 100644 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -10,7 +10,6 @@ C: db ( handle -- obj ) ! HOOK: db-create db ( str -- ) ! HOOK: db-drop db ( str -- ) GENERIC: db-open ( db -- ) -GENERIC: db-close ( db -- ) TUPLE: statement sql params handle bound? ; diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index f64b8d1104..aa7168530b 100644 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -1,5 +1,5 @@ USING: io io.files io.launcher kernel namespaces -prettyprint tools.test db.sqlite db db.sql sequences +prettyprint tools.test db.sqlite db sequences continuations ; IN: temporary diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 49462dcc50..73b93d404b 100644 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays assocs classes compiler db db.sql +USING: alien arrays assocs classes compiler db hashtables io.files kernel math math.parser namespaces prettyprint sequences strings tuples alien.c-types continuations db.sqlite.lib db.sqlite.ffi ; From 4066e1ca6b68512726bf66a9a4526a222ce770fe Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 13:34:01 -0600 Subject: [PATCH 06/62] start mysql --- extra/db/mysql/ffi/ffi.factor | 25 ++++++++++ extra/db/mysql/lib/lib.factor | 94 +++++++++++++++++++++++++++++++++++ extra/db/mysql/mysql.factor | 15 ++++++ 3 files changed, 134 insertions(+) create mode 100644 extra/db/mysql/ffi/ffi.factor create mode 100644 extra/db/mysql/lib/lib.factor create mode 100644 extra/db/mysql/mysql.factor diff --git a/extra/db/mysql/ffi/ffi.factor b/extra/db/mysql/ffi/ffi.factor new file mode 100644 index 0000000000..845381a23c --- /dev/null +++ b/extra/db/mysql/ffi/ffi.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2007 Berlin Brown, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +! Adapted from mysql.h and mysql.c +! Tested with MySQL version - 5.0.24a +USING: alien alien.syntax combinators kernel system ; +IN: db.mysql.ffi + +<< "mysql" { + { [ win32? ] [ "libmySQL.dll" "stdcall" ] } + { [ macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] } + { [ unix? ] [ "libmysqlclient.so.14" "cdecl" ] } +} cond add-library >> + +LIBRARY: mysql + +FUNCTION: void* mysql_init ( void* mysql ) ; +FUNCTION: char* mysql_error ( void* mysql ) ; +FUNCTION: void* mysql_real_connect ( void* mysql, char* host, char* user, char* passwd, char* db, int port, char* unixsocket, long clientflag ) ; +FUNCTION: void mysql_close ( void* sock ) ; +FUNCTION: int mysql_query ( void* mysql, char* q ) ; +FUNCTION: void* mysql_use_result ( void* mysql ) ; +FUNCTION: void mysql_free_result ( void* result ) ; +FUNCTION: char** mysql_fetch_row ( void* result ) ; +FUNCTION: int mysql_num_fields ( void* result ) ; +FUNCTION: ulong mysql_affected_rows ( void* mysql ) ; diff --git a/extra/db/mysql/lib/lib.factor b/extra/db/mysql/lib/lib.factor new file mode 100644 index 0000000000..7d5c2d55dc --- /dev/null +++ b/extra/db/mysql/lib/lib.factor @@ -0,0 +1,94 @@ +! Copyright (C) 2007 Berlin Brown, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for license. +! Adapted from mysql.h and mysql.c +! Tested with MySQL version - 5.0.24a +USING: kernel alien io prettyprint sequences +namespaces arrays math db.mysql.ffi system ; +IN: db.mysql.lib + +SYMBOL: my-conn + +TUPLE: mysql-db handle host user password db port ; +TUPLE: mysql-statement ; +TUPLE: mysql-result-set ; + +: new-mysql ( -- conn ) + f mysql_init ; + +: mysql-error-string ( mysql-connection -- str ) + mysql-db-handle mysql_error ; + +: mysql-error ( mysql -- ) + mysql-error-string throw ; + +: mysql-connect ( mysql-connection -- ) + init-mysql swap + [ set-mysql-connection-mysqlconn ] 2keep + [ mysql-connection-host ] keep + [ mysql-connection-user ] keep + [ mysql-connection-password ] keep + [ mysql-connection-db ] keep + [ mysql-connection-port f 0 mysql_real_connect ] keep + [ set-mysql-connection-handle ] keep + dup mysql-connection-handle + [ connect-error-msg throw ] unless ; + +! ========================================================= +! Low level mysql utility definitions +! ========================================================= + +: (mysql-query) ( mysql-connection query -- ret ) + >r mysql-connection-mysqlconn r> mysql_query ; + +: (mysql-result) ( mysql-connection -- ret ) + [ mysql-connection-mysqlconn mysql_use_result ] keep + [ set-mysql-connection-resulthandle ] keep ; + +: (mysql-affected-rows) ( mysql-connection -- n ) + mysql-connection-mysqlconn mysql_affected_rows ; + +: (mysql-free-result) ( mysql-connection -- ) + mysql-connection-resulthandle drop ; + +: (mysql-row) ( mysql-connection -- row ) + mysql-connection-resulthandle mysql_fetch_row ; + +: (mysql-num-cols) ( mysql-connection -- n ) + mysql-connection-resulthandle mysql_num_fields ; + +: mysql-char*-nth ( index object -- str ) + #! Utility based on 'char*-nth' to perform an additional sanity check on the value + #! extracted from the array of strings. + void*-nth [ alien>char-string ] [ "" ] if* ; + +: mysql-row>seq ( object n -- seq ) + [ swap mysql-char*-nth ] map-with ; + +: (mysql-result>seq) ( seq -- seq ) + my-conn get (mysql-row) dup [ + my-conn get (mysql-num-cols) mysql-row>seq + over push + (mysql-result>seq) + ] [ drop ] if + ! Perform needed cleanup on fetched results + my-conn get (mysql-free-result) ; + +! ========================================================= +! Public Word Definitions +! ========================================================= + + +: mysql-query ( query -- ret ) + >r my-conn get r> (mysql-query) drop + my-conn get (mysql-result) ; + +: mysql-command ( query -- n ) + mysql-query drop + my-conn get (mysql-affected-rows) ; + +: with-mysql ( host user password db port quot -- ) + [ + >r my-conn set + my-conn get mysql-connect drop r> + [ my-conn get mysql-close ] cleanup + ] with-scope ; inline diff --git a/extra/db/mysql/mysql.factor b/extra/db/mysql/mysql.factor new file mode 100644 index 0000000000..8043bc2782 --- /dev/null +++ b/extra/db/mysql/mysql.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for license. +USING: alien continuations io kernel prettyprint sequences +db ; +IN: db.mysql + +TUPLE: mysql-db handle host user password db port ; + +M: mysql-db db-open ( mysql-db -- ) + ; + +M: mysql-db dispose ( mysql-db -- ) + mysql-db-handle mysql_close ; + + From 13338b04f6f44499b700714bd07adc86ef666931 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 13:34:32 -0600 Subject: [PATCH 07/62] remove old mysql --- unmaintained/mysql/libmysql.factor | 35 ------ unmaintained/mysql/load.factor | 11 -- unmaintained/mysql/mysql.factor | 124 ------------------- unmaintained/mysql/test/create_database.sql | 17 --- unmaintained/mysql/test/mysql-example.factor | 57 --------- 5 files changed, 244 deletions(-) delete mode 100644 unmaintained/mysql/libmysql.factor delete mode 100644 unmaintained/mysql/load.factor delete mode 100644 unmaintained/mysql/mysql.factor delete mode 100644 unmaintained/mysql/test/create_database.sql delete mode 100644 unmaintained/mysql/test/mysql-example.factor diff --git a/unmaintained/mysql/libmysql.factor b/unmaintained/mysql/libmysql.factor deleted file mode 100644 index 064c7bffbc..0000000000 --- a/unmaintained/mysql/libmysql.factor +++ /dev/null @@ -1,35 +0,0 @@ -! See http://factorcode.org/license.txt -! Copyright (C) 2007 Berlin Brown -! Date: 1/17/2007 -! -! libs/mysql/libmysql.factor -! -! Adapted from mysql.h and mysql.c -! Tested with MySQL version - 5.0.24a - -IN: mysql -USING: alien kernel ; - -"mysql" { - { [ win32? ] [ "libmySQL.dll" "stdcall" ] } - { [ macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] } - { [ unix? ] [ "libmysqlclient.so.14" "cdecl" ] } -} cond add-library - -LIBRARY: mysql - -! =============================================== -! mysql.c -! =============================================== - -FUNCTION: void* mysql_init ( void* mysql ) ; -FUNCTION: char* mysql_error ( void* mysql ) ; -FUNCTION: void* mysql_real_connect ( void* mysql, char* host, char* user, char* passwd, char* db, int port, char* unixsocket, long clientflag ) ; -FUNCTION: void mysql_close ( void* sock ) ; -FUNCTION: int mysql_query ( void* mysql, char* q ) ; -FUNCTION: void* mysql_use_result ( void* mysql ) ; -FUNCTION: void mysql_free_result ( void* result ) ; -FUNCTION: char** mysql_fetch_row ( void* result ) ; -FUNCTION: int mysql_num_fields ( void* result ) ; -FUNCTION: ulong mysql_affected_rows ( void* mysql ) ; - diff --git a/unmaintained/mysql/load.factor b/unmaintained/mysql/load.factor deleted file mode 100644 index b3872d6259..0000000000 --- a/unmaintained/mysql/load.factor +++ /dev/null @@ -1,11 +0,0 @@ -! License: See http://factor.sf.net/license.txt for BSD license. -! Berlin Brown -! Date: 1/17/2007 -! -! Adapted from mysql.h and mysql.c -! Tested with MySQL version - 5.0.24a -PROVIDE: libs/mysql -{ +files+ { - "libmysql.factor" - "mysql.factor" -} } ; \ No newline at end of file diff --git a/unmaintained/mysql/mysql.factor b/unmaintained/mysql/mysql.factor deleted file mode 100644 index 22a6bc9248..0000000000 --- a/unmaintained/mysql/mysql.factor +++ /dev/null @@ -1,124 +0,0 @@ -! See http://factorcode.org/license.txt for license. -! Copyright (C) 2007 Berlin Brown -! Date: 1/17/2007 -! -! libs/mysql/mysql.factor -! -! Adapted from mysql.h and mysql.c -! Tested with MySQL version - 5.0.24a - -IN: mysql -USING: kernel alien errors io prettyprint - sequences namespaces arrays math tools generic ; - -SYMBOL: my-conn - -TUPLE: mysql-connection mysqlconn host user password db port handle resulthandle ; - -: init-mysql ( -- conn ) - f mysql_init ; - -C: mysql-connection ( host user password db port -- mysql-connection ) - [ set-mysql-connection-port ] keep - [ set-mysql-connection-db ] keep - [ set-mysql-connection-password ] keep - [ set-mysql-connection-user ] keep - [ set-mysql-connection-host ] keep ; - -: (mysql-error) ( mysql-connection -- str ) - mysql-connection-mysqlconn mysql_error ; - -: connect-error-msg ( mysql-connection -- s ) - mysql-connection-mysqlconn mysql_error - [ - "Couldn't connect to mysql database.\n" % - "Message: " % % - ] "" make ; - -: mysql-connect ( mysql-connection -- ) - init-mysql swap - [ set-mysql-connection-mysqlconn ] 2keep - [ mysql-connection-host ] keep - [ mysql-connection-user ] keep - [ mysql-connection-password ] keep - [ mysql-connection-db ] keep - [ mysql-connection-port f 0 mysql_real_connect ] keep - [ set-mysql-connection-handle ] keep - dup mysql-connection-handle - [ connect-error-msg throw ] unless ; - -! ========================================================= -! Low level mysql utility definitions -! ========================================================= - -: (mysql-query) ( mysql-connection query -- ret ) - >r mysql-connection-mysqlconn r> mysql_query ; - -: (mysql-result) ( mysql-connection -- ret ) - [ mysql-connection-mysqlconn mysql_use_result ] keep - [ set-mysql-connection-resulthandle ] keep ; - -: (mysql-affected-rows) ( mysql-connection -- n ) - mysql-connection-mysqlconn mysql_affected_rows ; - -: (mysql-free-result) ( mysql-connection -- ) - mysql-connection-resulthandle drop ; - -: (mysql-row) ( mysql-connection -- row ) - mysql-connection-resulthandle mysql_fetch_row ; - -: (mysql-num-cols) ( mysql-connection -- n ) - mysql-connection-resulthandle mysql_num_fields ; - -: mysql-char*-nth ( index object -- str ) - #! Utility based on 'char*-nth' to perform an additional sanity check on the value - #! extracted from the array of strings. - void*-nth [ alien>char-string ] [ "" ] if* ; - -: mysql-row>seq ( object n -- seq ) - [ swap mysql-char*-nth ] map-with ; - -: (mysql-result>seq) ( seq -- seq ) - my-conn get (mysql-row) dup [ - my-conn get (mysql-num-cols) mysql-row>seq - over push - (mysql-result>seq) - ] [ drop ] if - ! Perform needed cleanup on fetched results - my-conn get (mysql-free-result) ; - -! ========================================================= -! Public Word Definitions -! ========================================================= - -: mysql-close ( mysql-connection -- ) - mysql-connection-mysqlconn mysql_close ; - -: mysql-print-table ( seq -- ) - [ [ write bl ] each "\n" write ] each ; - -: mysql-query ( query -- ret ) - >r my-conn get r> (mysql-query) drop - my-conn get (mysql-result) ; - -: mysql-command ( query -- n ) - mysql-query drop - my-conn get (mysql-affected-rows) ; - -: mysql-error ( -- s ) - #! Get the last mysql error - my-conn get (mysql-error) ; - -: mysql-result>seq ( -- seq ) - V{ } clone (mysql-result>seq) ; - -: with-mysql ( host user password db port quot -- ) - [ - >r my-conn set - my-conn get mysql-connect drop r> - [ my-conn get mysql-close ] cleanup - ] with-scope ; inline - -: with-mysql-catch ( host user password db port quot -- ) - [ with-mysql ] catch [ "Caught: " write print ] when* ; - \ No newline at end of file diff --git a/unmaintained/mysql/test/create_database.sql b/unmaintained/mysql/test/create_database.sql deleted file mode 100644 index 00fd323046..0000000000 --- a/unmaintained/mysql/test/create_database.sql +++ /dev/null @@ -1,17 +0,0 @@ --- --- Create three databases (development / test / production) --- with prefix 'factordb_' -create database factordb_development; -create database factordb_test; -create database factordb_production; - -grant all on factordb_development.* to 'factoruser'@'localhost' identified by 'mysqlfactor'; -grant all on factordb_test.* to 'factoruser'@'localhost' identified by 'mysqlfactor'; -grant all on factordb_production.* to 'factoruser'@'localhost' identified by 'mysqlfactor'; - -grant all on factordb_development.* to 'factoruser'@'*' identified by 'mysqlfactor'; -grant all on factordb_test.* to 'factoruser'@'*' identified by 'mysqlfactor'; -grant all on factordb_production.* to 'factoruser'@'*' identified by 'mysqlfactor'; - --- End of the Script - diff --git a/unmaintained/mysql/test/mysql-example.factor b/unmaintained/mysql/test/mysql-example.factor deleted file mode 100644 index 2476153c8a..0000000000 --- a/unmaintained/mysql/test/mysql-example.factor +++ /dev/null @@ -1,57 +0,0 @@ -! See http://factorcode.org/license.txt for license. -! Simple test for mysql library -! libs/mysql/test/mysql-example.factor - -IN: mysql-example -REQUIRES: libs/mysql ; -USING: sequences mysql modules prettyprint kernel io math tools namespaces test ; - -"Testing..." print nl - -: get-drop-table ( -- s ) - "DROP TABLE if exists DISCUSSION_FORUM" ; - -: get-insert-table ( -- s ) - { - "INSERT INTO DISCUSSION_FORUM(category, full_name, email, title, main_url, keywords, message) " - "VALUES('none', 'John Doe', 'johndoe@test.com', 'The Message', NULL, NULL, 'Testing')" - } "" join ; - -: get-update-table ( -- s ) - "UPDATE DISCUSSION_FORUM set category = 'my-new-category'" ; - -: get-delete-table ( -- s ) - "DELETE FROM DISCUSSION_FORUM where id = 2" ; - -: get-create-table ( -- s ) - { - "create table DISCUSSION_FORUM(" - "id int(11) NOT NULL auto_increment," - "category varchar(128)," - "full_name varchar(128) NOT NULL," - "email varchar(128) NOT NULL," - "title varchar(255) NOT NULL," - "main_url varchar(255)," - "keywords varchar(255)," - "message text NOT NULL," - "created_on DATETIME NOT NULL DEFAULT '0000-00-0000:00:00'," - "PRIMARY KEY (id));" - } "" join ; - -[ "localhost" "factoruser" "mysqlfactor" "factordb_development" 0 [ - get-drop-table mysql-command drop - get-create-table mysql-command drop - get-update-table mysql-command drop - get-delete-table mysql-command drop - - ! Insert multiple records - 20 [ - get-insert-table mysql-command 2drop - ] each - - "select * from discussion_forum order by created_on" mysql-query drop - mysql-result>seq mysql-print-table - -] with-mysql ] time - -"Done" print \ No newline at end of file From eda2c710d450352314ebf9df616ebaa0e7d390dd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 13:38:59 -0600 Subject: [PATCH 08/62] add dll to script --- misc/factor.sh | 2 ++ 1 file changed, 2 insertions(+) diff --git a/misc/factor.sh b/misc/factor.sh index 02f4c4a542..fa8cdcd5b1 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -243,6 +243,8 @@ maybe_download_dlls() { check_ret wget wget http://factorcode.org/dlls/vorbis.dll check_ret wget + wget http://factorcode.org/dlls/sqlite3.dll + check_ret wget chmod 777 *.dll check_ret chmod fi From 354d85342e11f5465432e43662809fc5763d2af0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 13:57:22 -0600 Subject: [PATCH 09/62] remove dependency on sqlite3 binary --- extra/db/sqlite/sqlite-tests.factor | 45 +++++++++-------------------- 1 file changed, 13 insertions(+), 32 deletions(-) diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index aa7168530b..c6576dcd62 100644 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -3,40 +3,26 @@ prettyprint tools.test db.sqlite db sequences continuations ; IN: temporary -! "sqlite3 -init test.txt test.db" - -IN: scratchpad : test.db "extra/db/sqlite/test.db" resource-path ; -IN: temporary -: (create-db) ( -- str ) - [ - "sqlite3 -init " % - test.db % - " " % - test.db % - ] "" make ; +[ ] [ [ test.db delete-file ] catch drop ] unit-test -: create-db ( -- ) (create-db) run-process drop ; +[ ] [ + test.db [ + "create table person (name varchar(30), country varchar(30))" sql-command + "insert into person values('John', 'America')" sql-command + "insert into person values('Jane', 'New Zealand')" sql-command + ] with-sqlite +] unit-test -[ ] [ test.db delete-file ] unit-test -[ ] [ create-db ] unit-test - -[ - { - { "John" "America" } - { "Jane" "New Zealand" } - } -] [ +[ { { "John" "America" } { "Jane" "New Zealand" } } ] [ test.db [ "select * from person" sql-query ] with-sqlite ] unit-test -[ - { { "John" "America" } } -] [ +[ { { "John" "America" } } ] [ test.db [ "select * from person where name = :name and country = :country" [ @@ -52,15 +38,10 @@ IN: temporary ] with-sqlite ] unit-test -[ - { - { "1" "John" "America" } - { "2" "Jane" "New Zealand" } - } -] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test +[ { { "1" "John" "America" } { "2" "Jane" "New Zealand" } } ] +[ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test -[ -] [ +[ ] [ test.db [ "insert into person(name, country) values('Jimmy', 'Canada')" sql-command From aff818a07d82a013eb5a9963eeb4397bb0deb3f7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 16:40:14 -0600 Subject: [PATCH 10/62] add using --- extra/x/widgets/wm/frame/frame.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/x/widgets/wm/frame/frame.factor b/extra/x/widgets/wm/frame/frame.factor index 4e3b4e7c93..b75671fa3c 100755 --- a/extra/x/widgets/wm/frame/frame.factor +++ b/extra/x/widgets/wm/frame/frame.factor @@ -4,6 +4,7 @@ USING: kernel io combinators namespaces quotations arrays sequences x11.xlib x11.constants mortar mortar.sugar slot-accessors geom.rect + math.bitfields x x.gc x.widgets x.widgets.button x.widgets.wm.child From c0c08985c5c46c877ebefcceb034751e6143bd94 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 17:10:49 -0600 Subject: [PATCH 11/62] make hardware-info load on windows --- extra/hardware-info/hardware-info.factor | 7 +++--- .../windows/backend/backend.factor | 6 ----- extra/hardware-info/windows/ce/ce.factor | 4 ++-- extra/hardware-info/windows/nt/nt.factor | 24 +++++++++---------- extra/hardware-info/windows/windows.factor | 7 +++--- 5 files changed, 21 insertions(+), 27 deletions(-) delete mode 100644 extra/hardware-info/windows/backend/backend.factor diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor index 0515646a5f..69b8678749 100755 --- a/extra/hardware-info/hardware-info.factor +++ b/extra/hardware-info/hardware-info.factor @@ -1,12 +1,13 @@ -USING: alien.syntax kernel math prettyprint system -combinators vocabs.loader hardware-info.backend ; +USING: alien.syntax kernel math prettyprint +combinators vocabs.loader hardware-info.backend system ; IN: hardware-info : kb. ( x -- ) 10 2^ /f . ; : megs. ( x -- ) 20 2^ /f . ; : gigs. ( x -- ) 30 2^ /f . ; -<< { +<< +{ { [ windows? ] [ "hardware-info.windows" ] } { [ linux? ] [ "hardware-info.linux" ] } { [ macosx? ] [ "hardware-info.macosx" ] } diff --git a/extra/hardware-info/windows/backend/backend.factor b/extra/hardware-info/windows/backend/backend.factor deleted file mode 100644 index 516603c441..0000000000 --- a/extra/hardware-info/windows/backend/backend.factor +++ /dev/null @@ -1,6 +0,0 @@ -IN: hardware-info.windows.backend - -TUPLE: wince ; -TUPLE: winnt ; -UNION: windows wince winnt ; - diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor index 1592bad14c..8923d86b03 100755 --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/hardware-info/windows/ce/ce.factor @@ -2,8 +2,8 @@ USING: alien.c-types hardware-info kernel math namespaces windows windows.kernel32 hardware-info.backend ; IN: hardware-info.windows.ce -TUPLE: wince ; -T{ wince } os set-global +TUPLE: wince-os ; +T{ wince-os } os set-global : memory-status ( -- MEMORYSTATUS ) "MEMORYSTATUS" diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor index 827b32c2f2..8bdb75fe6a 100755 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -1,16 +1,15 @@ -USING: alien alien.c-types hardware-info.windows.backend +USING: alien alien.c-types kernel libc math namespaces hardware-info.backend windows windows.advapi32 windows.kernel32 ; IN: hardware-info.windows.nt -TUPLE: winnt ; - -T{ winnt } os set-global +TUPLE: winnt-os ; +T{ winnt-os } os set-global : system-info ( -- SYSTEM_INFO ) "SYSTEM_INFO" [ GetSystemInfo ] keep ; -M: winnt cpus ( -- n ) +M: winnt-os cpus ( -- n ) system-info SYSTEM_INFO-dwNumberOfProcessors ; : memory-status ( -- MEMORYSTATUSEX ) @@ -18,25 +17,25 @@ M: winnt cpus ( -- n ) "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength [ GlobalMemoryStatusEx ] keep swap zero? [ win32-error ] when ; -M: winnt memory-load ( -- n ) +M: winnt-os memory-load ( -- n ) memory-status MEMORYSTATUSEX-dwMemoryLoad ; -M: winnt physical-mem ( -- n ) +M: winnt-os physical-mem ( -- n ) memory-status MEMORYSTATUSEX-ullTotalPhys ; -M: winnt available-mem ( -- n ) +M: winnt-os available-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailPhys ; -M: winnt total-page-file ( -- n ) +M: winnt-os total-page-file ( -- n ) memory-status MEMORYSTATUSEX-ullTotalPageFile ; -M: winnt available-page-file ( -- n ) +M: winnt-os available-page-file ( -- n ) memory-status MEMORYSTATUSEX-ullAvailPageFile ; -M: winnt total-virtual-mem ( -- n ) +M: winnt-os total-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullTotalVirtual ; -M: winnt available-virtual-mem ( -- n ) +M: winnt-os available-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailVirtual ; : computer-name ( -- string ) @@ -54,4 +53,3 @@ M: winnt available-virtual-mem ( -- n ) ] [ [ alien>u16-string ] keep free ] if ; - diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index 67d13fc50f..f3a1eb33f5 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -1,7 +1,7 @@ USING: alien alien.c-types kernel libc math namespaces windows windows.kernel32 windows.advapi32 -hardware-info.windows.backend -words combinators vocabs.loader hardware-info.backend ; +words combinators vocabs.loader hardware-info.backend +system ; IN: hardware-info.windows : system-info ( -- SYSTEM_INFO ) @@ -63,7 +63,8 @@ IN: hardware-info.windows : system-windows-directory ( -- str ) \ GetSystemWindowsDirectory get-directory ; +<< { { [ wince? ] [ "hardware-info.windows.ce" ] } { [ winnt? ] [ "hardware-info.windows.nt" ] } -} cond [ require ] when* +} cond [ require ] when* >> From 5c21b08606848c3c776534fa9c7a8432bb2eb234 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 17:11:55 -0600 Subject: [PATCH 12/62] remove a line of comments --- extra/db/postgresql/ffi/ffi.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index dbaa70c625..23368164a1 100644 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -1,6 +1,5 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -! adapted from libpq-fe.h version 7.4.7 ! tested on debian linux with postgresql 8.1 USING: alien alien.syntax combinators system ; From 123aabc730b17e49f8ba27804514f4159db1fe43 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 17:33:59 -0600 Subject: [PATCH 13/62] Fix Mac Intel alignment issue --- core/cpu/x86/32/32.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index d3e33c46bd..4ed186d769 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -261,6 +261,10 @@ windows? [ cell "ulonglong" c-type set-c-type-align ] unless +macosx? [ + cell "double" c-type set-c-type-align +] when + T{ x86-backend f 4 } compiler-backend set-global : sse2? "Intrinsic" throw ; From 1ae14bbacfcc5c4a58d904779d286a745979a750 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 17:53:04 -0600 Subject: [PATCH 14/62] skeletonize mysql --- extra/db/mysql/lib/lib.factor | 102 ++++++++++++++-------------------- extra/db/mysql/mysql.factor | 45 ++++++++++++++- 2 files changed, 87 insertions(+), 60 deletions(-) diff --git a/extra/db/mysql/lib/lib.factor b/extra/db/mysql/lib/lib.factor index 7d5c2d55dc..59d1b6ff3d 100644 --- a/extra/db/mysql/lib/lib.factor +++ b/extra/db/mysql/lib/lib.factor @@ -14,81 +14,65 @@ TUPLE: mysql-result-set ; : new-mysql ( -- conn ) f mysql_init ; - -: mysql-error-string ( mysql-connection -- str ) - mysql-db-handle mysql_error ; : mysql-error ( mysql -- ) - mysql-error-string throw ; + [ mysql_error throw ] when* ; : mysql-connect ( mysql-connection -- ) - init-mysql swap - [ set-mysql-connection-mysqlconn ] 2keep - [ mysql-connection-host ] keep - [ mysql-connection-user ] keep - [ mysql-connection-password ] keep - [ mysql-connection-db ] keep - [ mysql-connection-port f 0 mysql_real_connect ] keep - [ set-mysql-connection-handle ] keep - dup mysql-connection-handle - [ connect-error-msg throw ] unless ; + new-mysql over set-mysql-db-handle + dup { + mysql-db-handle + mysql-db-host + mysql-db-user + mysql-db-password + mysql-db-db + mysql-db-port + } get-slots f 0 mysql_real_connect mysql-error ; ! ========================================================= ! Low level mysql utility definitions ! ========================================================= : (mysql-query) ( mysql-connection query -- ret ) - >r mysql-connection-mysqlconn r> mysql_query ; + >r mysql-db-handle r> mysql_query ; -: (mysql-result) ( mysql-connection -- ret ) - [ mysql-connection-mysqlconn mysql_use_result ] keep - [ set-mysql-connection-resulthandle ] keep ; - -: (mysql-affected-rows) ( mysql-connection -- n ) - mysql-connection-mysqlconn mysql_affected_rows ; +! : (mysql-result) ( mysql-connection -- ret ) + ! [ mysql-db-handle mysql_use_result ] keep + ! [ set-mysql-connection-resulthandle ] keep ; -: (mysql-free-result) ( mysql-connection -- ) - mysql-connection-resulthandle drop ; +! : (mysql-affected-rows) ( mysql-connection -- n ) + ! mysql-connection-mysqlconn mysql_affected_rows ; -: (mysql-row) ( mysql-connection -- row ) - mysql-connection-resulthandle mysql_fetch_row ; +! : (mysql-free-result) ( mysql-connection -- ) + ! mysql-connection-resulthandle drop ; -: (mysql-num-cols) ( mysql-connection -- n ) - mysql-connection-resulthandle mysql_num_fields ; +! : (mysql-row) ( mysql-connection -- row ) + ! mysql-connection-resulthandle mysql_fetch_row ; + +! : (mysql-num-cols) ( mysql-connection -- n ) + ! mysql-connection-resulthandle mysql_num_fields ; -: mysql-char*-nth ( index object -- str ) - #! Utility based on 'char*-nth' to perform an additional sanity check on the value - #! extracted from the array of strings. - void*-nth [ alien>char-string ] [ "" ] if* ; - -: mysql-row>seq ( object n -- seq ) - [ swap mysql-char*-nth ] map-with ; - -: (mysql-result>seq) ( seq -- seq ) - my-conn get (mysql-row) dup [ - my-conn get (mysql-num-cols) mysql-row>seq - over push - (mysql-result>seq) - ] [ drop ] if - ! Perform needed cleanup on fetched results - my-conn get (mysql-free-result) ; - -! ========================================================= -! Public Word Definitions -! ========================================================= +! : mysql-char*-nth ( index object -- str ) + ! #! Utility based on 'char*-nth' to perform an additional sanity check on the value + ! #! extracted from the array of strings. + ! void*-nth [ alien>char-string ] [ "" ] if* ; +! : mysql-row>seq ( object n -- seq ) + ! [ swap mysql-char*-nth ] map-with ; -: mysql-query ( query -- ret ) - >r my-conn get r> (mysql-query) drop - my-conn get (mysql-result) ; +! : (mysql-result>seq) ( seq -- seq ) + ! my-conn get (mysql-row) dup [ + ! my-conn get (mysql-num-cols) mysql-row>seq + ! over push + ! (mysql-result>seq) + ! ] [ drop ] if + ! ! Perform needed cleanup on fetched results + ! my-conn get (mysql-free-result) ; -: mysql-command ( query -- n ) - mysql-query drop - my-conn get (mysql-affected-rows) ; +! : mysql-query ( query -- ret ) + ! >r my-conn get r> (mysql-query) drop + ! my-conn get (mysql-result) ; -: with-mysql ( host user password db port quot -- ) - [ - >r my-conn set - my-conn get mysql-connect drop r> - [ my-conn get mysql-close ] cleanup - ] with-scope ; inline +! : mysql-command ( query -- n ) + ! mysql-query drop + ! my-conn get (mysql-affected-rows) ; diff --git a/extra/db/mysql/mysql.factor b/extra/db/mysql/mysql.factor index 8043bc2782..941c25e1fa 100644 --- a/extra/db/mysql/mysql.factor +++ b/extra/db/mysql/mysql.factor @@ -1,10 +1,12 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for license. USING: alien continuations io kernel prettyprint sequences -db ; +db db.mysql.ffi ; IN: db.mysql TUPLE: mysql-db handle host user password db port ; +TUPLE: mysql-statement ; +TUPLE: mysql-result-set ; M: mysql-db db-open ( mysql-db -- ) ; @@ -13,3 +15,44 @@ M: mysql-db dispose ( mysql-db -- ) mysql-db-handle mysql_close ; +M: mysql-db ( str -- statement ) + ; + +M: mysql-db ( str -- statement ) + ; + +M: mysql-statement prepare-statement ( statement -- ) + ; + +M: mysql-statement bind-statement* ( statement -- ) + ; + +M: mysql-statement rebind-statement ( statement -- ) + ; + +M: mysql-statement execute-statement ( statement -- ) + ; + +M: mysql-statement query-results ( query -- result-set ) + ; + +M: mysql-result-set #rows ( result-set -- n ) + ; + +M: mysql-result-set #columns ( result-set -- n ) + ; + +M: mysql-result-set row-column ( result-set n -- obj ) + ; + +M: mysql-result-set advance-row ( result-set -- ? ) + ; + +M: mysql-db begin-transaction ( -- ) + ; + +M: mysql-db commit-transaction ( -- ) + ; + +M: mysql-db rollback-transaction ( -- ) + ; From 21183af0ceb70821d6de9b6c0dcc5b8f824522ff Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 17:56:00 -0600 Subject: [PATCH 15/62] remove sudo requirement --- misc/factor.sh | 1 - 1 file changed, 1 deletion(-) diff --git a/misc/factor.sh b/misc/factor.sh index fa8cdcd5b1..d1ef738cd9 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -45,7 +45,6 @@ check_gcc_version() { } check_installed_programs() { - ensure_program_installed sudo ensure_program_installed chmod ensure_program_installed uname ensure_program_installed git From e9b5a6b9d30a1ad21d46978731c4ffc202df8b43 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 19:38:19 -0600 Subject: [PATCH 16/62] with-process-stream waits for process exit --- extra/io/launcher/launcher-docs.factor | 4 ++-- extra/io/launcher/launcher.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index c30516a83f..e372f7a41e 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -146,8 +146,8 @@ HELP: with-process-stream { $values { "desc" "a launch descriptor" } { "quot" quotation } - { "process" process } } -{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". When the quotation returns, the " { $link process } " instance is output." } ; + { "status" "an exit code" } } +{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". After the quotation returns, waits for the process to end and outputs the exit code." } ; HELP: wait-for-process { $values { "process" process } { "status" integer } } diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 09a77fe985..9be90d28de 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -98,10 +98,10 @@ TUPLE: process-stream process ; { set-delegate set-process-stream-process } process-stream construct ; -: with-process-stream ( desc quot -- process ) +: with-process-stream ( desc quot -- status ) swap [ swap with-stream ] keep - process-stream-process ; inline + process-stream-process wait-for-process ; inline : notify-exit ( status process -- ) [ set-process-status ] keep From 2872bc9d306c553b1546a46983d660d36e6dcafd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 19:38:31 -0600 Subject: [PATCH 17/62] More method cleanups --- core/compiler/compiler.factor | 2 +- core/effects/effects.factor | 20 +++++++---------- core/generic/generic-docs.factor | 4 ---- core/generic/generic-tests.factor | 3 +++ core/generic/generic.factor | 32 +++++++++++++++------------ core/generic/standard/standard.factor | 2 +- core/inference/backend/backend.factor | 4 ++-- core/words/words.factor | 5 ++++- 8 files changed, 37 insertions(+), 35 deletions(-) diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 631c2e4f53..2674734483 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -26,7 +26,7 @@ IN: compiler >r dupd save-effect r> f pick compiler-error over compiled-unxref - compiled-xref ; + over crossref? [ compiled-xref ] [ 2drop ] if ; : compile-succeeded ( word -- effect dependencies ) [ diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 10ebca6dea..23e8daf122 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math namespaces sequences strings words assocs combinators ; @@ -41,17 +41,13 @@ M: integer (stack-picture) drop "object" ; ")" % ] "" make ; -: stack-effect ( word -- effect/f ) - { - { [ dup symbol? ] [ drop 0 1 ] } - { [ dup "parent-generic" word-prop ] [ - "parent-generic" word-prop stack-effect - ] } - { [ t ] [ - { "declared-effect" "inferred-effect" } - swap word-props [ at ] curry map [ ] find nip - ] } - } cond ; +GENERIC: stack-effect ( word -- effect/f ) + +M: symbol stack-effect drop 0 1 ; + +M: word stack-effect + { "declared-effect" "inferred-effect" } + swap word-props [ at ] curry map [ ] find nip ; M: effect clone [ effect-in clone ] keep effect-out clone ; diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index f4da9575e9..631aa7e62d 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -107,10 +107,6 @@ HELP: make-generic { $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." } $low-level-note ; -HELP: init-methods -{ $values { "word" word } } -{ $description "Prepare to define a generic word." } ; - HELP: define-generic { $values { "word" word } { "combination" "a method combination" } } { $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." } diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index dc888ec30c..f0d5bf3063 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -176,6 +176,9 @@ M: f tag-and-f 4 ; ! define-class hashing issue TUPLE: debug-combination ; +M: debug-combination make-default-method + 2drop [ "Oops" throw ] when ; + M: debug-combination perform-combination drop order [ dup class-hashes ] { } map>assoc sort-keys diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 951813dbcd..78577eaed4 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! 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 ; +quotations arrays vocabs effects ; IN: generic ! Method combination protocol @@ -65,15 +65,20 @@ TUPLE: check-method class generic ; : make-method-def ( quot word combination -- quot ) "combination" word-prop method-prologue swap append ; +PREDICATE: word method-body "method" word-prop >boolean ; + +M: method-body stack-effect + "method" word-prop method-generic stack-effect ; + : ( quot class generic -- word ) [ make-method-def ] 2keep - [ method-word-name f dup ] keep - "parent-generic" set-word-prop + method-word-name f dup rot define ; : ( quot class generic -- method ) check-method - [ ] 3keep f \ method construct-boa ; + [ ] 3keep f \ method construct-boa + dup method-word over "method" set-word-prop ; : define-method ( quot class generic -- ) >r bootstrap-word r> @@ -120,13 +125,12 @@ M: class forget* ( class -- ) M: assoc update-methods ( assoc -- ) implementors* [ make-generic ] each ; -: init-methods ( word -- ) - dup "methods" word-prop - H{ } assoc-like - "methods" set-word-prop ; - : define-generic ( word combination -- ) - 2dup "combination" set-word-prop - dupd define-default-method - dup init-methods - make-generic ; + over "combination" word-prop over = [ + 2drop + ] [ + 2dup "combination" set-word-prop + over H{ } clone "methods" set-word-prop + dupd define-default-method + make-generic + ] if ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 94ac82a0e4..d52208ccbf 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -10,7 +10,7 @@ TUPLE: standard-combination # ; M: standard-combination method-prologue standard-combination-# object - swap add [ declare ] curry ; + swap add* [ declare ] curry ; C: standard-combination diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 34179bbf32..b839b047d6 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -10,8 +10,8 @@ IN: inference.backend recursive-state get at ; : inline? ( word -- ? ) - dup "parent-generic" word-prop - [ inline? ] [ "inline" word-prop ] ?if ; + dup "method" word-prop + [ method-generic inline? ] [ "inline" word-prop ] ?if ; : local-recursive-state ( -- assoc ) recursive-state get dup keys diff --git a/core/words/words.factor b/core/words/words.factor index b4062d8f02..93b1185335 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -116,13 +116,16 @@ SYMBOL: changed-words [ no-compilation-unit ] unless* set-at ; +: crossref? ( word -- ? ) + dup word-vocabulary swap "method" word-prop or ; + : define ( word def -- ) [ ] like over unxref over redefined over set-word-def dup changed-word - dup word-vocabulary [ dup xref ] when drop ; + dup crossref? [ dup xref ] when drop ; : define-declared ( word def effect -- ) pick swap "declared-effect" set-word-prop From 77a2a2136a0d4837c6f00e66d784fce9bf8d8a97 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 19:43:10 -0600 Subject: [PATCH 18/62] Better method usages work in progres --- core/generic/generic.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 78577eaed4..2100f49423 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -134,3 +134,13 @@ M: assoc update-methods ( assoc -- ) dupd define-default-method make-generic ] if ; + +: subwords ( generic -- seq ) + dup "methods" word-prop values + swap "default-method" word-prop add + [ method-word ] map ; + +: xref-generics ( -- ) + all-words + [ generic? ] subset + [ subwords [ xref ] each ] each ; From 3433adefbe9e8397e5a0f84b4275b50d4da100f0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 19:58:07 -0600 Subject: [PATCH 19/62] Fix wait-for-pid --- extra/unix/process/process.factor | 2 +- extra/unix/unix.factor | 36 +++++++++++++++++++------------ 2 files changed, 23 insertions(+), 15 deletions(-) diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor index fb4271ea23..8b7144b979 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -32,4 +32,4 @@ IN: unix.process fork dup zero? -roll swap curry if ; inline : wait-for-pid ( pid -- status ) - 0 [ 0 waitpid drop ] keep *int ; \ No newline at end of file + 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; \ No newline at end of file diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 7c3467b052..750a4b5044 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -177,31 +177,39 @@ FUNCTION: int kill ( pid_t pid, int sig ) ; ! Flags for waitpid -: WNOHANG 1 ; -: WUNTRACED 2 ; +: WNOHANG 1 ; inline +: WUNTRACED 2 ; inline -: WSTOPPED 2 ; -: WEXITED 4 ; -: WCONTINUED 8 ; -: WNOWAIT HEX: 1000000 ; +: WSTOPPED 2 ; inline +: WEXITED 4 ; inline +: WCONTINUED 8 ; inline +: WNOWAIT HEX: 1000000 ; inline ! Examining status -: WTERMSIG ( status -- value ) HEX: 7f bitand ; +: WTERMSIG ( status -- value ) + HEX: 7f bitand ; inline -: WIFEXITED ( status -- ? ) WTERMSIG zero? ; +: WIFEXITED ( status -- ? ) + WTERMSIG zero? ; inline -: WEXITSTATUS ( status -- value ) HEX: ff00 bitand -8 shift ; +: WEXITSTATUS ( status -- value ) + HEX: ff00 bitand -8 shift ; inline -: WIFSIGNALED ( status -- ? ) HEX: 7f bitand 1+ -1 shift 0 > ; +: WIFSIGNALED ( status -- ? ) + HEX: 7f bitand 1+ -1 shift 0 > ; inline -: WCOREFLAG ( -- value ) HEX: 80 ; +: WCOREFLAG ( -- value ) + HEX: 80 ; inline -: WCOREDUMP ( status -- ? ) WCOREFLAG bitand zero? not ; +: WCOREDUMP ( status -- ? ) + WCOREFLAG bitand zero? not ; inline -: WIFSTOPPED ( status -- ? ) HEX: ff bitand HEX: 7f = ; +: WIFSTOPPED ( status -- ? ) + HEX: ff bitand HEX: 7f = ; inline -: WSTOPSIG ( status -- value ) WEXITSTATUS ; +: WSTOPSIG ( status -- value ) + WEXITSTATUS ; inline FUNCTION: pid_t wait ( int* status ) ; FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; From f1989fc8c6142671cc27d5f0d14041b05a104d50 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 20:10:00 -0600 Subject: [PATCH 20/62] Fix io.launcher again --- extra/io/unix/launcher/launcher.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index b44ac80159..93278e2b1a 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -111,7 +111,7 @@ M: unix-io process-stream* 2drop t ] [ find-process dup [ - >r *uint r> notify-exit f + >r *int WEXITSTATUS r> notify-exit f ] [ 2drop f ] if From 6aabef8e3213d0a92fff3688142ae30b5b5e066b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 20:49:40 -0600 Subject: [PATCH 21/62] git pull to master delete staging.*.image --- misc/factor.sh | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/misc/factor.sh b/misc/factor.sh index d1ef738cd9..c8e0456b3a 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -196,7 +196,7 @@ git_clone() { git_pull_factorcode() { echo "Updating the git repository from factorcode.org..." - git pull git://factorcode.org/git/factor.git + git pull git://factorcode.org/git/factor.git master check_ret git } @@ -219,6 +219,7 @@ delete_boot_images() { echo "Deleting old images..." rm $BOOT_IMAGE > /dev/null 2>&1 rm $BOOT_IMAGE.* > /dev/null 2>&1 + rm staging.*.image > /dev/null 2>&1 } get_boot_image() { From b2cd79ebddb28c312dd1f9bce7bdd756cf6a0bbf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 20:49:59 -0600 Subject: [PATCH 22/62] Fix deploy --- extra/tools/deploy/backend/backend.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index d768b6a334..95d19712c0 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -80,6 +80,7 @@ IN: tools.deploy.backend ] { } make ; : make-deploy-image ( vm image vocab config -- ) + make-boot-image dup staging-image-name exists? [ >r pick r> tuck make-staging-image ] unless From 1f66e8173f955a28416560be41f28707b68bba31 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 4 Feb 2008 21:26:59 -0600 Subject: [PATCH 23/62] builder: convert to io.launcher --- extra/builder/builder.factor | 151 +++++++++++++++++++---------------- 1 file changed, 82 insertions(+), 69 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 38570ae46f..cb0720d0a9 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,7 +1,7 @@ -USING: kernel io io.files io.launcher tools.deploy.backend - system namespaces sequences splitting math.parser - unix prettyprint tools.time calendar bake vars ; +USING: kernel io io.files io.launcher hashtables tools.deploy.backend + system continuations namespaces sequences splitting math.parser + prettyprint tools.time calendar bake vars http.client ; IN: builder @@ -19,16 +19,20 @@ IN: builder SYMBOL: builder-recipients -: quote ( str -- str ) "'" swap "'" 3append ; - : email-file ( subject file -- ) `{ - "cat" , - "| mutt -s" ,[ quote ] - "-x" %[ builder-recipients get ] - } - " " join system drop ; - + { +stdin+ , } + { +arguments+ { "mutt" "-s" , %[ builder-recipients get ] } } + } + >hashtable run-process drop ; + +: email-string ( subject -- ) + `{ "mutt" "-s" , %[ builder-recipients get ] } + + dup + dispose + process-stream-process wait-for-process drop ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; @@ -41,74 +45,83 @@ VAR: stamp : build ( -- ) -datestamp >stamp + datestamp >stamp -"/builds/factor" cd -"git pull git://factorcode.org/git/factor.git" system -0 = -[ ] -[ - "builder: git pull" "/dev/null" email-file - "builder: git pull" throw -] -if + "/builds/factor" cd + + { "git" "pull" "--no-summary" "git://factorcode.org/git/factor.git" } + run-process process-status + 0 = + [ ] + [ + "builder: git pull" email-string + "builder: git pull" throw + ] + if -"/builds/" stamp> append make-directory -"/builds/" stamp> append cd -"git clone /builds/factor" system drop + "/builds/" stamp> append make-directory + "/builds/" stamp> append cd -"factor" cd + { "git" "clone" "/builds/factor" } run-process drop -{ "git" "show" } -[ readln ] with-stream -" " split second -"../git-id" [ print ] with-stream + "factor" cd -"make clean" system drop + { "git" "show" } + [ readln ] with-stream + " " split second + "../git-id" [ print ] with-stream -"make " target " > ../compile-log" 3append system -0 = -[ ] -[ - "builder: vm compile" "../compile-log" email-file - "builder: vm compile" throw -] if + { "make" "clean" } run-process drop -"wget http://factorcode.org/images/latest/" boot-image-name append system -0 = -[ ] -[ - "builder: image download" "/dev/null" email-file - "builder: image download" throw -] if + `{ + { +arguments+ { "make" ,[ target ] } } + { +stdout+ "../compile-log" } + { +stderr+ +stdout+ } + } + >hashtable run-process process-status + 0 = + [ ] + [ + "builder: vm compile" "../compile-log" email-file + "builder: vm compile" throw + ] if -[ - "./factor -i=" boot-image-name " -no-user-init > ../boot-log" - 3append - system -] -benchmark nip -"../boot-time" [ . ] with-stream -0 = -[ ] -[ - "builder: bootstrap" "../boot-log" email-file - "builder: bootstrap" throw -] if + [ "http://factorcode.org/images/latest/" boot-image-name append download ] + [ "builder: image download" email-string ] + recover -[ - "./factor -e='USE: tools.browser load-everything' > ../load-everything-log" - system -] benchmark nip -"../load-everything-time" [ . ] with-stream -0 = -[ ] -[ - "builder: load-everything" "../load-everything-log" email-file - "builder: load-everything" throw -] if + `{ + { +arguments+ { + "./factor" + ,[ "-i=" boot-image-name append ] + "-no-user-init" + } } + { +stdout+ "../boot-log" } + { +stderr+ +stdout+ } + } + >hashtable + [ run-process process-status ] + benchmark nip "../boot-time" [ . ] with-stream + 0 = + [ ] + [ + "builder: bootstrap" "../boot-log" email-file + "builder: bootstrap" throw + ] if -; + `{ + { +arguments+ { "./factor" "-e=USE: tools.browser load-everything" } } + { +stdout+ "../load-everything-log" } + { +stderr+ +stdout+ } + } + >hashtable [ run-process process-status ] benchmark nip + "../load-everything-time" [ . ] with-stream + 0 = + [ ] + [ + "builder: load-everything" "../load-everything-log" email-file + "builder: load-everything" throw + ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From bd2226d89e09fa14a600238277166a490be96984 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 4 Feb 2008 21:58:57 -0600 Subject: [PATCH 24/62] builder: add factor-binary word --- extra/builder/builder.factor | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index cb0720d0a9..d20b5b8e5b 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,7 +1,8 @@ USING: kernel io io.files io.launcher hashtables tools.deploy.backend system continuations namespaces sequences splitting math.parser - prettyprint tools.time calendar bake vars http.client ; + prettyprint tools.time calendar bake vars http.client + combinators ; IN: builder @@ -39,6 +40,15 @@ SYMBOL: builder-recipients ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: factor-binary ( -- name ) + os + { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] } + { "windows" [ "./factor-nt.exe" ] } + [ drop "./factor" ] } + case ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + VAR: stamp ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -92,7 +102,7 @@ VAR: stamp `{ { +arguments+ { - "./factor" + ,[ factor-binary ] ,[ "-i=" boot-image-name append ] "-no-user-init" } } @@ -110,7 +120,8 @@ VAR: stamp ] if `{ - { +arguments+ { "./factor" "-e=USE: tools.browser load-everything" } } + { +arguments+ + { ,[ factor-binary ] "-e=USE: tools.browser load-everything" } } { +stdout+ "../load-everything-log" } { +stderr+ +stdout+ } } From 659b6d8f3c3e2ca0f5deed100e8ace971dd7e4c7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 23:30:38 -0600 Subject: [PATCH 25/62] Better assert-depth error --- core/debugger/debugger.factor | 30 ++++++++++++++++++++++++++---- 1 file changed, 26 insertions(+), 4 deletions(-) diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 77c6da38e9..53f3387d85 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -87,7 +87,32 @@ TUPLE: assert got expect ; : depth ( -- n ) datastack length ; -: assert-depth ( quot -- ) depth slip depth swap assert= ; +: 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 ; + +M: relative-underflow summary + drop "Too many items removed from data stack" ; + +TUPLE: 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 ] } + { 0 [ 2drop ] } + { 1 [ relative-overflow ] } + } case ; inline : expired-error. ( obj -- ) "Object did not survive image save/load: " write third . ; @@ -222,9 +247,6 @@ M: redefine-error error. "Re-definition of " write redefine-error-def . ; -M: forward-error error. - "Forward reference to " write forward-error-word . ; - M: undefined summary drop "Calling a deferred word before it has been defined" ; From 87887a11654619d03ca37e7d63a87196c5506a7e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 23:30:49 -0600 Subject: [PATCH 26/62] Monitors tweak --- extra/io/unix/linux/linux.factor | 10 ++-------- extra/io/windows/nt/monitor/monitor.factor | 16 ++++++++-------- 2 files changed, 10 insertions(+), 16 deletions(-) diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 1707ac9546..dcf1beabf9 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -25,8 +25,6 @@ TUPLE: inotify watches ; : wd>monitor ( wd -- monitor ) watches at ; -: wd>path ( wd -- path ) wd>monitor linux-monitor-path ; - : ( -- port ) H{ } clone inotify_init dup io-error inotify @@ -89,12 +87,8 @@ M: linux-monitor dispose ( monitor -- ) ] { } make ; : parse-file-notify ( buffer -- changed path ) - { - inotify-event-wd - inotify-event-name - inotify-event-mask - } get-slots - parse-action -rot alien>char-string >r wd>path r> path+ ; + { inotify-event-name inotify-event-mask } get-slots + parse-action swap alien>char-string ; : events-exhausted? ( i buffer -- ? ) buffer-fill >= ; diff --git a/extra/io/windows/nt/monitor/monitor.factor b/extra/io/windows/nt/monitor/monitor.factor index d418dff270..6f956760a8 100755 --- a/extra/io/windows/nt/monitor/monitor.factor +++ b/extra/io/windows/nt/monitor/monitor.factor @@ -65,20 +65,20 @@ M: windows-nt-io ( path recursive? -- monitor ) { [ t ] [ +modify-file+ ] } } cond nip ; -: parse-file-notify ( directory buffer -- changed path ) +: parse-file-notify ( buffer -- changed path ) { FILE_NOTIFY_INFORMATION-FileName FILE_NOTIFY_INFORMATION-FileNameLength FILE_NOTIFY_INFORMATION-Action - } get-slots parse-action 1array -rot - memory>u16-string path+ ; + } get-slots parse-action 1array swap + memory>u16-string ; -: (changed-files) ( directory buffer -- ) - 2dup parse-file-notify changed-file +: (changed-files) ( buffer -- ) + dup parse-file-notify changed-file dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero? - [ 3drop ] [ swap (changed-files) ] if ; + [ 2drop ] [ swap (changed-files) ] if ; M: windows-nt-io fill-queue ( monitor -- ) - dup win32-monitor-path over buffer-ptr pick read-changes - [ zero? [ 2drop ] [ (changed-files) ] if ] H{ } make-assoc + dup buffer-ptr over read-changes + [ zero? [ drop ] [ (changed-files) ] if ] H{ } make-assoc swap set-monitor-queue ; From 2d3298d611ab2fd1dcdfa2b7577928299d8de9bf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 23:30:59 -0600 Subject: [PATCH 27/62] Method usages cleanup --- core/bootstrap/image/image.factor | 8 +------- core/bootstrap/stage2.factor | 1 + core/compiler/units/units-docs.factor | 9 +-------- core/compiler/units/units.factor | 5 ----- core/definitions/definitions-docs.factor | 4 +--- core/definitions/definitions-tests.factor | 4 +++- core/generic/generic-tests.factor | 2 +- core/generic/generic.factor | 13 ++++++++----- core/generic/standard/standard.factor | 2 +- core/inference/inference.factor | 11 +++++++---- core/optimizer/backend/backend.factor | 2 +- core/parser/parser-docs.factor | 4 +--- core/parser/parser-tests.factor | 4 ++-- core/parser/parser.factor | 10 +++------- core/source-files/source-files.factor | 14 ++++++++++++++ core/vocabs/loader/loader-tests.factor | 2 +- core/words/words-tests.factor | 3 ++- extra/tools/browser/browser.factor | 2 +- extra/tools/crossref/crossref.factor | 17 +---------------- 19 files changed, 50 insertions(+), 67 deletions(-) mode change 100644 => 100755 core/compiler/units/units-docs.factor diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 60e73cb249..3dadee5193 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -203,14 +203,8 @@ M: f ' ! Words -DEFER: emit-word - -: emit-generic ( generic -- ) - dup "default-method" word-prop method-word emit-word - "methods" word-prop [ nip method-word emit-word ] assoc-each ; - : emit-word ( word -- ) - dup generic? [ dup emit-generic ] when + dup subwords [ emit-word ] each [ dup hashcode ' , dup word-name ' , diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 7a0fab8a99..f3483add57 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -24,6 +24,7 @@ IN: bootstrap.stage2 "Cross-referencing..." print flush H{ } clone crossref set-global xref-words + xref-generics xref-sources ] unless diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor old mode 100644 new mode 100755 index 363b5b5014..99124d40ae --- a/core/compiler/units/units-docs.factor +++ b/core/compiler/units/units-docs.factor @@ -28,9 +28,7 @@ HELP: redefine-error HELP: remember-definition { $values { "definition" "a definition specifier" } { "loc" "a " { $snippet "{ path line# }" } " pair" } } -{ $description "Saves the location of a definition and associates this definition with the current source file." -$nl -"This is the book-keeping required to detect " { $link redefine-error } " and " { $link forward-error } "." } ; +{ $description "Saves the location of a definition and associates this definition with the current source file." } ; HELP: old-definitions { $var-description "Stores an assoc where the keys form the set of definitions which were defined by " { $link file } " the most recent time it was loaded." } ; @@ -38,11 +36,6 @@ HELP: old-definitions HELP: new-definitions { $var-description "Stores an assoc where the keys form the set of definitions which were defined so far by the current parsing of " { $link file } "." } ; -HELP: forward-error -{ $values { "word" word } } -{ $description "Throws a " { $link forward-error } "." } -{ $description "Indicates a word is being referenced prior to the location of its most recent definition. This can only happen if a source file is loaded, and subsequently edited such that two dependent definitions are reversed." } ; - HELP: with-compilation-unit { $values { "quot" quotation } } { $description "Calls a quotation in a new compilation unit. The quotation can define new words and classes, as well as forget words. When the quotation returns, any changed words are recompiled, and changes are applied atomically." } diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 68e1a79185..242ed9854a 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -26,11 +26,6 @@ TUPLE: redefine-error def ; over new-definitions get first key? [ dup redefine-error ] when new-definitions get second (remember-definition) ; -TUPLE: forward-error word ; - -: forward-error ( word -- ) - \ forward-error construct-boa throw ; - : forward-reference? ( word -- ? ) dup old-definitions get assoc-stack [ new-definitions get assoc-stack not ] diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index eec88bba0c..d855a14be9 100755 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -52,9 +52,7 @@ $nl $nl "If the parser did not have special checks for this case, then the modified source file would still load, because when the definition of " { $snippet "hello-world" } " on line 4 is being parsed, the " { $snippet "world" } " word is already present in the dictionary from an earlier run. The developer would then not discover this mistake until attempting to load the source file into a fresh image." $nl -"Since this is undesirable, the parser explicitly raises an error if a source file refers to a word which is in the dictionary, but defined after it is used." -{ $subsection forward-error } -"If a source file raises a " { $link forward-error } " when loaded into a development image, then it would have raised a " { $link no-word } " error when loaded into a fresh image." +"Since this is undesirable, the parser explicitly raises a " { $link no-word } " error if a source file refers to a word which is in the dictionary, but defined after it is used." $nl "The parser also catches duplicate definitions. If an artifact is defined twice in the same source file, the earlier definition will never be accessible, and this is almost always a mistake, perhaps due to a bad choice of word names, or a copy and paste error. The parser raises an error in this case." { $subsection redefine-error } ; diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index a4cb4de902..f0b0888052 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -6,6 +6,8 @@ TUPLE: combination-1 ; M: combination-1 perform-combination 2drop { } [ ] each [ ] ; +M: combination-1 make-default-method 2drop [ "No method" throw ] ; + SYMBOL: generic-1 [ @@ -20,7 +22,7 @@ SYMBOL: generic-1 ] with-compilation-unit ] unit-test -GENERIC: some-generic +GENERIC: some-generic ( a -- b ) USE: arrays diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index f0d5bf3063..f1e1ebd6d2 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -177,7 +177,7 @@ M: f tag-and-f 4 ; TUPLE: debug-combination ; M: debug-combination make-default-method - 2drop [ "Oops" throw ] when ; + 2drop [ "Oops" throw ] ; M: debug-combination perform-combination drop diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 2100f49423..453d72effb 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -73,7 +73,8 @@ M: method-body stack-effect : ( quot class generic -- word ) [ make-method-def ] 2keep method-word-name f - dup rot define ; + dup rot define + dup xref ; : ( quot class generic -- method ) check-method @@ -135,12 +136,14 @@ M: assoc update-methods ( assoc -- ) make-generic ] if ; -: subwords ( generic -- seq ) +GENERIC: subwords ( word -- seq ) + +M: word subwords drop f ; + +M: generic subwords dup "methods" word-prop values swap "default-method" word-prop add [ method-word ] map ; : xref-generics ( -- ) - all-words - [ generic? ] subset - [ subwords [ xref ] each ] each ; + all-words [ subwords [ xref ] each ] each ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index d52208ccbf..88f6a05bc2 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -91,7 +91,7 @@ TUPLE: no-method object generic ; : class-hash-dispatch-quot ( methods quot picker -- quot ) >r >r hash-methods r> map - hash-dispatch-quot r> [ class-hash ] rot 3append ; + hash-dispatch-quot r> [ class-hash ] rot 3append ; inline : big-generic ( methods -- quot ) [ small-generic ] picker class-hash-dispatch-quot ; diff --git a/core/inference/inference.factor b/core/inference/inference.factor index 0fc344dd85..3f52eaadf4 100755 --- a/core/inference/inference.factor +++ b/core/inference/inference.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: inference.backend inference.state inference.dataflow inference.known-words inference.transforms inference.errors -sequences prettyprint io effects kernel namespaces quotations -words vocabs ; +kernel io effects namespaces sequences quotations vocabs +generic words ; IN: inference GENERIC: infer ( quot -- effect ) @@ -28,4 +28,7 @@ M: callable dataflow-with ] with-infer nip ; : forget-errors ( -- ) - all-words [ f "no-effect" set-word-prop ] each ; + all-words [ + dup subwords [ f "no-effect" set-word-prop ] each + f "no-effect" set-word-prop + ] each ; diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 27b1b1e0ec..9d75346091 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -256,7 +256,7 @@ M: #dispatch optimize-node* tuck dispatching-class dup [ swap [ 2array ] 2keep method method-word - dup word-def flat-length 5 >= + dup word-def flat-length 6 >= [ 1quotation ] [ word-def ] if ] [ 2drop t t diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 30e259c033..d8d6c9b7bc 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -202,9 +202,7 @@ HELP: location HELP: save-location { $values { "definition" "a definition specifier" } } -{ $description "Saves the location of a definition and associates this definition with the current source file." -$nl -"This is the book-keeping required to detect " { $link redefine-error } " and " { $link forward-error } "." } ; +{ $description "Saves the location of a definition and associates this definition with the current source file." } ; HELP: parser-notes { $var-description "A boolean controlling whether the parser will print various notes and warnings. Switched on by default. If a source file is being run for its effect on the " { $link stdio } " stream, this variable should be switched off, to prevent parser notes from polluting the output." } ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index b00e8e26b4..f503528a24 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -342,7 +342,7 @@ IN: temporary [ "IN: temporary \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] catch [ forward-error? ] is? + ] catch [ no-word? ] is? ] unit-test [ ] [ @@ -354,7 +354,7 @@ IN: temporary [ "IN: temporary \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] catch [ forward-error? ] is? + ] catch [ no-word? ] is? ] unit-test [ t ] [ diff --git a/core/parser/parser.factor b/core/parser/parser.factor index ffecf9493e..6d7ad47843 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -235,7 +235,8 @@ M: no-word summary : no-word ( name -- newword ) dup \ no-word construct-boa - swap words-named word-restarts throw-restarts + swap words-named [ forward-reference? not ] subset + word-restarts throw-restarts dup word-vocabulary (use+) ; : check-forward ( str word -- word ) @@ -244,7 +245,7 @@ M: no-word summary dup use get [ at ] with map [ ] subset [ forward-reference? not ] find nip - [ ] [ forward-error ] ?if + [ ] [ no-word ] ?if ] [ nip ] if ; @@ -415,11 +416,6 @@ SYMBOL: interactive-vocabs over stack. ] when 2drop ; -: outside-usages ( seq -- usages ) - dup [ - over usage [ pathname? not ] subset seq-diff - ] curry { } map>assoc ; - : filter-moved ( assoc -- newassoc ) [ drop where dup [ first ] when diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index c974145928..64ae2e376e 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -96,3 +96,17 @@ SYMBOL: file source-file-definitions old-definitions set [ ] [ file get rollback-source-file ] cleanup ] with-scope ; inline + +: smart-usage ( word -- definitions ) + \ f or usage [ + dup method-body? [ + "method" word-prop + { method-specializer method-generic } get-slots + 2array + ] when + ] map ; + +: outside-usages ( seq -- usages ) + dup [ + over smart-usage [ pathname? not ] subset seq-diff + ] curry { } map>assoc ; diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index f38276d318..560affa566 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -79,7 +79,7 @@ IN: temporary "resource:core/vocabs/loader/test/a/a.factor" parse-stream - ] catch [ forward-error? ] is? + ] catch [ no-word? ] is? ] unit-test 0 "count-me" set-global diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 2455250dc9..35a2421e71 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -87,7 +87,8 @@ FORGET: foe ] unit-test [ t ] [ - \ * usage [ word? ] subset [ interned? not ] subset empty? + \ * usage [ word? ] subset + [ dup interned? swap method-body? or ] all? ] unit-test DEFER: calls-a-gensym diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 370e55eb97..dabc37e5de 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -238,7 +238,7 @@ C: vocab-author : vocab-xref ( vocab quot -- vocabs ) >r dup vocab-name swap words r> map [ [ word? ] subset [ word-vocabulary ] map ] map>set - remove [ vocab ] map ; inline + remove [ ] subset [ vocab ] map ; inline : vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; diff --git a/extra/tools/crossref/crossref.factor b/extra/tools/crossref/crossref.factor index 663df61926..f6561e9f26 100755 --- a/extra/tools/crossref/crossref.factor +++ b/extra/tools/crossref/crossref.factor @@ -3,7 +3,7 @@ USING: arrays definitions assocs io kernel math namespaces prettyprint sequences strings io.styles words generic tools.completion quotations parser inspector -sorting hashtables vocabs ; +sorting hashtables vocabs parser source-files ; IN: tools.crossref : synopsis-alist ( definitions -- alist ) @@ -12,21 +12,6 @@ IN: tools.crossref : definitions. ( alist -- ) [ write-object nl ] assoc-each ; -: (method-usage) ( word generic -- methods ) - tuck methods - [ second uses member? ] with subset keys - swap [ 2array ] curry map ; - -: method-usage ( word seq -- methods ) - [ generic? ] subset [ (method-usage) ] with map concat ; - -: compound-usage ( words -- seq ) - [ generic? not ] subset ; - -: smart-usage ( word -- definitions ) - \ f or - dup usage dup compound-usage -rot method-usage append ; - : usage. ( word -- ) smart-usage synopsis-alist sort-keys definitions. ; From 751a1da3d2fb1ee36d4d5e01238307ff371c4a2f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 23:48:18 -0600 Subject: [PATCH 28/62] Builder tweak --- extra/builder/builder.factor | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) mode change 100644 => 100755 extra/builder/builder.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor old mode 100644 new mode 100755 index d20b5b8e5b..3216105d47 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -14,7 +14,7 @@ IN: builder ,[ dup timestamp-day ] ,[ dup timestamp-hour ] ,[ timestamp-minute ] } - [ number>string 2 CHAR: 0 pad-left ] map "-" join ; + [ pad-00 ] map "-" join ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -29,10 +29,7 @@ SYMBOL: builder-recipients : email-string ( subject -- ) `{ "mutt" "-s" , %[ builder-recipients get ] } - - dup - dispose - process-stream-process wait-for-process drop ; + [ ] with-process-stream drop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From ba1a958a321efdec8be27cdb4c7b0edcffd13468 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 13:11:36 -0600 Subject: [PATCH 29/62] Move cd and cwd primitives to native I/O, fix Windows normalize-pathname --- core/bootstrap/primitives.factor | 2 - core/bootstrap/stage2.factor | 6 +-- core/io/files/files-docs.factor | 4 +- core/io/files/files.factor | 6 ++- extra/io/unix/files/files.factor | 9 +++- extra/io/windows/nt/backend/backend.factor | 37 +------------ extra/io/windows/nt/files/files.factor | 62 ++++++++++++++++++++-- extra/io/windows/nt/nt-tests.factor | 6 ++- extra/unix/bsd/bsd.factor | 2 + extra/unix/linux/linux.factor | 2 + extra/unix/unix.factor | 1 + extra/windows/kernel32/kernel32.factor | 6 ++- vm/io.h | 2 - vm/os-unix.c | 13 ----- vm/os-windows-ce.c | 10 ---- vm/os-windows-nt.c | 15 ------ vm/os-windows.h | 1 + vm/primitives.c | 2 - 18 files changed, 93 insertions(+), 93 deletions(-) mode change 100644 => 100755 extra/unix/bsd/bsd.factor mode change 100644 => 100755 extra/unix/linux/linux.factor mode change 100644 => 100755 vm/io.h diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 550aac71b0..967840a3dc 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -553,8 +553,6 @@ builtins get num-tags get tail f union-class define-class { "millis" "system" } { "type" "kernel.private" } { "tag" "kernel.private" } - { "cwd" "io.files" } - { "cd" "io.files" } { "modify-code-heap" "compiler.units" } { "dlopen" "alien" } { "dlsym" "alien" } diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index f3483add57..c601ba7671 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: init command-line namespaces words debugger io kernel.private math memory continuations kernel io.files io.backend system parser vocabs sequences prettyprint vocabs.loader combinators splitting source-files strings definitions assocs compiler.errors compiler.units -math.parser ; +math.parser generic ; IN: bootstrap.stage2 ! Wrap everything in a catch which starts a listener so @@ -88,5 +88,5 @@ IN: bootstrap.stage2 "output-image" get resource-path save-image-and-exit ] if ] [ - print-error :c "listener" vocab-main execute + print-error :c "listener" vocab-main execute 1 exit ] recover diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 3a23c8f6ef..0b9a748eb8 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -52,12 +52,12 @@ HELP: { $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." } { $errors "Throws an error if the file cannot be opened for writing." } ; -HELP: cwd ( -- path ) +HELP: cwd { $values { "path" "a pathname string" } } { $description "Outputs the current working directory of the Factor process." } { $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; -HELP: cd ( path -- ) +HELP: cd { $values { "path" "a pathname string" } } { $description "Changes the current working directory of the Factor process." } { $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 6e4648b590..9952e6387b 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -1,10 +1,14 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.files USING: io.backend io.files.private io hashtables kernel math memory namespaces sequences strings assocs arrays definitions system combinators splitting sbufs ; +HOOK: cd io-backend ( path -- ) + +HOOK: cwd io-backend ( -- path ) + HOOK: io-backend ( path -- stream ) HOOK: io-backend ( path -- stream ) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index edee598435..3201c29c45 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,9 +1,16 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.nonblocking io.unix.backend io.files io unix kernel math continuations math.bitfields ; IN: io.unix.files +M: unix-io cwd + MAXPATHLEN dup getcwd + [ alien>char-string ] [ (io-error) ] if* ; + +M: unix-io cd + chdir io-error ; + : read-flags O_RDONLY ; inline : open-read ( path -- fd ) diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 88e7cdf84a..760bcec457 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -2,45 +2,10 @@ USING: alien alien.c-types arrays assocs combinators continuations destructors io io.backend io.nonblocking io.windows libc kernel math namespaces sequences threads tuples.lib windows windows.errors windows.kernel32 -strings splitting io.files qualified ascii ; +strings splitting io.files qualified ascii combinators.lib ; QUALIFIED: windows.winsock IN: io.windows.nt.backend -: unicode-prefix ( -- seq ) - "\\\\?\\" ; inline - -M: windows-nt-io root-directory? ( path -- ? ) - dup length 2 = [ - dup first Letter? - swap second CHAR: : = and - ] [ - drop f - ] if ; - -M: windows-nt-io normalize-pathname ( string -- string ) - dup string? [ "pathname must be a string" throw ] unless - "/" split "\\" join - { - ! empty - { [ dup empty? ] [ "empty path" throw ] } - ! .\\foo - { [ dup ".\\" head? ] [ - >r unicode-prefix cwd r> 1 tail 3append - ] } - ! c:\\foo - { [ dup 1 tail ":" head? ] [ >r unicode-prefix r> append ] } - ! \\\\?\\c:\\foo - { [ dup unicode-prefix head? ] [ ] } - ! foo.txt ..\\foo.txt - { [ t ] [ - [ - unicode-prefix % cwd % - dup first CHAR: \\ = [ CHAR: \\ , ] unless % - ] "" make - ] } - } cond [ "/\\." member? ] right-trim - dup peek CHAR: : = [ "\\" append ] when ; - SYMBOL: io-hash TUPLE: io-callback port continuation ; diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 4a304e5ac9..43686707a2 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,8 +1,64 @@ -USING: continuations destructors io.buffers io.nonblocking -io.windows io.windows.nt.backend kernel libc math threads -windows windows.kernel32 ; +USING: continuations destructors io.buffers io.files io.backend +io.nonblocking io.windows io.windows.nt.backend kernel libc math +threads windows windows.kernel32 alien.c-types alien.arrays +sequences combinators combinators.lib ascii splitting alien +strings ; IN: io.windows.nt.files +M: windows-nt-io cwd + MAX_UNICODE_PATH dup "ushort" + [ GetCurrentDirectory win32-error=0/f ] keep + alien>u16-string ; + +M: windows-nt-io cd + SetCurrentDirectory win32-error=0/f ; + +: unicode-prefix ( -- seq ) + "\\\\?\\" ; inline + +M: windows-nt-io root-directory? ( path -- ? ) + dup length 2 = [ + dup first Letter? + swap second CHAR: : = and + ] [ + drop f + ] if ; + +: root-directory ( string -- string' ) + { + [ dup length 2 >= ] + [ dup second CHAR: : = ] + [ dup first Letter? ] + } && [ 2 head ] [ "Not an absolute path" throw ] if ; + +: prepend-prefix ( string -- string' ) + unicode-prefix swap append ; + +: windows-path+ ( cwd path -- newpath ) + { + ! empty + { [ dup empty? ] [ "empty path" throw ] } + ! \\\\?\\c:\\foo + { [ dup unicode-prefix head? ] [ nip ] } + ! ..\\foo + { [ dup "..\\" head? ] [ >r parent-directory r> 2 tail windows-path+ ] } + ! .\\foo + { [ dup ".\\" head? ] [ 1 tail append prepend-prefix ] } + ! \\foo + { [ dup "\\" head? ] [ >r root-directory r> append prepend-prefix ] } + ! c:\\foo + { [ dup second CHAR: : = ] [ nip prepend-prefix ] } + ! foo.txt + { [ t ] [ [ first CHAR: \\ = "" "\\" ? ] keep 3append prepend-prefix ] } + } cond ; + +M: windows-nt-io normalize-pathname ( string -- string ) + dup string? [ "pathname must be a string" throw ] unless + "/" split "\\" join + cwd swap windows-path+ + [ "/\\." member? ] right-trim + dup peek CHAR: : = [ "\\" append ] when ; + M: windows-nt-io CreateFile-flags ( DWORD -- DWORD ) FILE_FLAG_OVERLAPPED bitor ; diff --git a/extra/io/windows/nt/nt-tests.factor b/extra/io/windows/nt/nt-tests.factor index 9dfef6796d..ad409fb083 100755 --- a/extra/io/windows/nt/nt-tests.factor +++ b/extra/io/windows/nt/nt-tests.factor @@ -1,4 +1,4 @@ -USING: io.files kernel tools.test ; +USING: io.files kernel tools.test io.backend splitting ; IN: temporary [ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test @@ -14,3 +14,7 @@ IN: temporary [ f ] [ "c:\\foo" root-directory? ] unit-test [ f ] [ "." root-directory? ] unit-test [ f ] [ ".." root-directory? ] unit-test + +[ ] [ "" resource-path cd ] unit-test + +[ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test diff --git a/extra/unix/bsd/bsd.factor b/extra/unix/bsd/bsd.factor old mode 100644 new mode 100755 index 0a5aa1080e..e652f1b9f9 --- a/extra/unix/bsd/bsd.factor +++ b/extra/unix/bsd/bsd.factor @@ -5,6 +5,8 @@ USING: alien.syntax ; ! FreeBSD +: MAXPATHLEN 1024 ; inline + : O_RDONLY HEX: 0000 ; inline : O_WRONLY HEX: 0001 ; inline : O_RDWR HEX: 0002 ; inline diff --git a/extra/unix/linux/linux.factor b/extra/unix/linux/linux.factor old mode 100644 new mode 100755 index 0a3eb7ee5f..11db6cc862 --- a/extra/unix/linux/linux.factor +++ b/extra/unix/linux/linux.factor @@ -5,6 +5,8 @@ USING: alien.syntax ; ! Linux. +: MAXPATHLEN 1024 ; inline + : O_RDONLY HEX: 0000 ; inline : O_WRONLY HEX: 0001 ; inline : O_RDWR HEX: 0002 ; inline diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 750a4b5044..d32fc25eab 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -124,6 +124,7 @@ FUNCTION: void freeaddrinfo ( addrinfo* ai ) ; FUNCTION: int futimes ( int id, timeval[2] times ) ; FUNCTION: char* gai_strerror ( int ecode ) ; FUNCTION: int getaddrinfo ( char* hostname, char* servname, addrinfo* hints, addrinfo** res ) ; +FUNCTION: char* getcwd ( char* buf, size_t size ) ; FUNCTION: int getdtablesize ; FUNCTION: gid_t getegid ; FUNCTION: uid_t geteuid ; diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 45bd6bfae9..b8928c5820 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -892,7 +892,8 @@ FUNCTION: DWORD GetConsoleTitleW ( LPWSTR lpConsoleTitle, DWORD nSize ) ; ! FUNCTION: GetCurrentActCtx ! FUNCTION: GetCurrentConsoleFont ! FUNCTION: GetCurrentDirectoryA -! FUNCTION: GetCurrentDirectoryW +FUNCTION: BOOL GetCurrentDirectoryW ( DWORD len, LPTSTR buf ) ; +: GetCurrentDirectory GetCurrentDirectoryW ; inline FUNCTION: HANDLE GetCurrentProcess ( ) ; ! FUNCTION: GetCurrentProcessId FUNCTION: HANDLE GetCurrentThread ( ) ; @@ -1387,7 +1388,8 @@ FUNCTION: BOOL SetConsoleTitleW ( LPCWSTR lpConsoleTitle ) ; ! FUNCTION: SetCPGlobal ! FUNCTION: SetCriticalSectionSpinCount ! FUNCTION: SetCurrentDirectoryA -! FUNCTION: SetCurrentDirectoryW +FUNCTION: BOOL SetCurrentDirectoryW ( LPCWSTR lpDirectory ) ; +: SetCurrentDirectory SetCurrentDirectoryW ; inline ! FUNCTION: SetDefaultCommConfigA ! FUNCTION: SetDefaultCommConfigW ! FUNCTION: SetDllDirectoryA diff --git a/vm/io.h b/vm/io.h old mode 100644 new mode 100755 index d8cc2a0578..39e7390c3e --- a/vm/io.h +++ b/vm/io.h @@ -13,5 +13,3 @@ DECLARE_PRIMITIVE(fread); DECLARE_PRIMITIVE(open_file); DECLARE_PRIMITIVE(stat); DECLARE_PRIMITIVE(read_dir); -DECLARE_PRIMITIVE(cwd); -DECLARE_PRIMITIVE(cd); diff --git a/vm/os-unix.c b/vm/os-unix.c index 41dbe9cabf..92028dfc43 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -115,19 +115,6 @@ DEFINE_PRIMITIVE(read_dir) dpush(result); } -DEFINE_PRIMITIVE(cwd) -{ - char wd[MAXPATHLEN]; - if(getcwd(wd,MAXPATHLEN) == NULL) - io_error(); - box_char_string(wd); -} - -DEFINE_PRIMITIVE(cd) -{ - chdir(unbox_char_string()); -} - DEFINE_PRIMITIVE(os_envs) { GROWABLE_ARRAY(result); diff --git a/vm/os-windows-ce.c b/vm/os-windows-ce.c index e68a6385ae..9b73692aa0 100755 --- a/vm/os-windows-ce.c +++ b/vm/os-windows-ce.c @@ -10,16 +10,6 @@ s64 current_millis(void) | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10000; } -DEFINE_PRIMITIVE(cwd) -{ - not_implemented_error(); -} - -DEFINE_PRIMITIVE(cd) -{ - not_implemented_error(); -} - char *strerror(int err) { /* strerror() is not defined on WinCE */ diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index e356c2f674..99ac21f62f 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -8,21 +8,6 @@ s64 current_millis(void) - EPOCH_OFFSET) / 10000; } -DEFINE_PRIMITIVE(cwd) -{ - F_CHAR buf[MAX_UNICODE_PATH]; - - if(!GetCurrentDirectory(MAX_UNICODE_PATH, buf)) - io_error(); - - box_u16_string(buf); -} - -DEFINE_PRIMITIVE(cd) -{ - SetCurrentDirectory(unbox_u16_string()); -} - DEFINE_PRIMITIVE(os_envs) { GROWABLE_ARRAY(result); diff --git a/vm/os-windows.h b/vm/os-windows.h index f252c214af..a22252fde8 100755 --- a/vm/os-windows.h +++ b/vm/os-windows.h @@ -30,6 +30,7 @@ typedef wchar_t F_CHAR; F_STRING *get_error_message(void); DLLEXPORT F_CHAR *error_message(DWORD id); +void windows_error(void); void init_ffi(void); void ffi_dlopen(F_DLL *dll, bool error); diff --git a/vm/primitives.c b/vm/primitives.c index f2f8ccf18d..dc7333c667 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -109,8 +109,6 @@ void *primitives[] = { primitive_millis, primitive_type, primitive_tag, - primitive_cwd, - primitive_cd, primitive_modify_code_heap, primitive_dlopen, primitive_dlsym, From 50484f3e699a94cf0549db63023cae7f45ffb91c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 16:35:42 -0600 Subject: [PATCH 30/62] Fix MIMIC: --- extra/delegate/delegate.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index c0da9c51bc..667805dcc3 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -39,7 +39,7 @@ M: tuple-class group-words : define-mimic ( group mimicker mimicked -- ) >r >r group-words r> r> [ pick "methods" word-prop at dup - [ method-def spin define-method ] [ 3drop ] if + [ method-def spin define-method ] [ 3drop ] if ] 2curry each ; : MIMIC: From 2b9f977912d1472bd909ad58432aa98fd2403e32 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 16:35:57 -0600 Subject: [PATCH 31/62] Fix Windows normalize-pathname --- extra/io/windows/nt/files/files.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 43686707a2..5cbcd063bd 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,8 +1,8 @@ USING: continuations destructors io.buffers io.files io.backend io.nonblocking io.windows io.windows.nt.backend kernel libc math threads windows windows.kernel32 alien.c-types alien.arrays -sequences combinators combinators.lib ascii splitting alien -strings ; +sequences combinators combinators.lib sequences.lib ascii +splitting alien strings ; IN: io.windows.nt.files M: windows-nt-io cwd @@ -47,7 +47,7 @@ M: windows-nt-io root-directory? ( path -- ? ) ! \\foo { [ dup "\\" head? ] [ >r root-directory r> append prepend-prefix ] } ! c:\\foo - { [ dup second CHAR: : = ] [ nip prepend-prefix ] } + { [ dup ?second CHAR: : = ] [ nip prepend-prefix ] } ! foo.txt { [ t ] [ [ first CHAR: \\ = "" "\\" ? ] keep 3append prepend-prefix ] } } cond ; From 4297777e19bf43a735419f2e898edcfaaa9655eb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 16:36:11 -0600 Subject: [PATCH 32/62] better logging for webapps.planet --- extra/io/server/server.factor | 17 +++++++++-------- extra/webapps/planet/planet.factor | 20 +++++++++++++------- 2 files changed, 22 insertions(+), 15 deletions(-) diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 408fd29714..3c3d2c20f5 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io io.sockets io.files continuations kernel math math.parser namespaces parser sequences strings @@ -9,11 +9,14 @@ IN: io.server SYMBOL: log-stream +: with-log-stream ( quot -- ) + log-stream get swap with-stream* ; inline + : log-message ( str -- ) - log-stream get [ + [ "[" write now timestamp>string write "] " write print flush - ] with-stream* ; + ] with-log-stream ; : log-error ( str -- ) "Error: " swap append log-message ; @@ -24,15 +27,13 @@ SYMBOL: log-stream : log-file ( service -- path ) ".log" append resource-path ; -: with-log-stream ( stream quot -- ) - log-stream swap with-variable ; inline - : with-log-file ( file quot -- ) >r r> - [ with-log-stream ] curry with-disposal ; inline + [ log-stream swap with-variable ] curry + with-disposal ; inline : with-log-stdio ( quot -- ) - stdio get swap with-log-stream ; + stdio get log-stream rot with-variable ; inline : with-logging ( service quot -- ) over [ diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index e9105ee459..ede0c579de 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -2,7 +2,7 @@ USING: sequences rss arrays concurrency kernel sorting html.elements io assocs namespaces math threads vocabs html furnace http.server.templating calendar math.parser splitting continuations debugger system http.server.responders -xml.writer prettyprint ; +xml.writer prettyprint io.server ; IN: webapps.planet : print-posting-summary ( posting -- ) @@ -75,13 +75,11 @@ SYMBOL: cached-postings SYMBOL: last-update -: diagnostic write print flush ; - : fetch-feed ( triple -- feed ) second - dup "Fetching " diagnostic + "Fetching " over append log-message dup download-feed feed-entries - swap "Done fetching " diagnostic ; + "Done fetching " swap append log-message ; : ( author entry -- entry' ) clone @@ -89,7 +87,11 @@ SYMBOL: last-update [ set-entry-title ] keep ; : ?fetch-feed ( triple -- feed/f ) - [ fetch-feed ] [ swap . error. f ] recover ; + [ + fetch-feed + ] [ + swap [ . error. ] with-log-stream f + ] recover ; : fetch-blogroll ( blogroll -- entries ) dup 0 @@ -111,7 +113,11 @@ SYMBOL: last-update update-thread ; : start-update-thread ( -- ) - [ update-thread ] in-thread ; + [ + "webapps.planet" [ + update-thread + ] with-logging + ] in-thread ; "planet" "planet-factor" "extra/webapps/planet" web-app From be39d64ef8e3f7aec8300883ab5a0903f7362b67 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 17:07:37 -0600 Subject: [PATCH 33/62] Check fork() error code --- extra/unix/process/process.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor index 8b7144b979..c315d10d7f 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -8,7 +8,8 @@ IN: unix.process ! to implement io.launcher on Unix. User code should use ! io.launcher instead. -: >argv ( seq -- alien ) [ malloc-char-string ] map f add >c-void*-array ; +: >argv ( seq -- alien ) + [ malloc-char-string ] map f add >c-void*-array ; : exec ( pathname argv -- int ) [ malloc-char-string ] [ >argv ] bi* execv ; @@ -29,7 +30,7 @@ IN: unix.process >r [ first ] [ ] bi r> exec-with-env ; : with-fork ( child parent -- ) - fork dup zero? -roll swap curry if ; inline + 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 From acf236342c8fd42d1ebc8bac81835e20eaa2e0bd Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 5 Feb 2008 17:15:41 -0600 Subject: [PATCH 34/62] Fixing XML's whitespace handling --- extra/state-parser/state-parser.factor | 2 +- extra/xml/xml.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/state-parser/state-parser.factor b/extra/state-parser/state-parser.factor index 19a4af44cc..3f51a52e1b 100644 --- a/extra/state-parser/state-parser.factor +++ b/extra/state-parser/state-parser.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: io io.streams.string kernel math namespaces sequences -strings circular prettyprint debugger unicode.categories ; +strings circular prettyprint debugger ascii ; IN: state-parser ! * Basic underlying words diff --git a/extra/xml/xml.factor b/extra/xml/xml.factor index 65a8e28dea..ec3e24b99d 100644 --- a/extra/xml/xml.factor +++ b/extra/xml/xml.factor @@ -3,7 +3,7 @@ USING: io io.streams.string io.files kernel math namespaces prettyprint sequences arrays generic strings vectors xml.char-classes xml.data xml.errors xml.tokenize xml.writer -xml.utilities state-parser assocs unicode.categories ; +xml.utilities state-parser assocs ascii ; IN: xml ! -- Overall parser with data tree From ede3254f0ab9ac092177481af3c5e994a18eb65c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 17:27:29 -0600 Subject: [PATCH 35/62] Bootstrap prints restarts --- core/bootstrap/stage2.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index c601ba7671..1a9bdd599a 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -88,5 +88,7 @@ IN: bootstrap.stage2 "output-image" get resource-path save-image-and-exit ] if ] [ - print-error :c "listener" vocab-main execute 1 exit + print-error :c restarts. + "listener" vocab-main execute + 1 exit ] recover From 898770f774005f701301146aaa421fba934b0286 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 17:31:27 -0600 Subject: [PATCH 36/62] Bootstrap fixes --- extra/io/unix/files/files.factor | 3 ++- extra/unix/process/process.factor | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 3201c29c45..a70f7339d2 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.nonblocking io.unix.backend io.files io -unix kernel math continuations math.bitfields ; +unix kernel math continuations math.bitfields byte-arrays +alien ; IN: io.unix.files M: unix-io cwd diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor index c315d10d7f..6fdc8e358b 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -1,6 +1,6 @@ USING: kernel alien.c-types sequences math unix combinators.cleave vectors kernel namespaces continuations -threads assocs vectors ; +threads assocs vectors io.unix.backend ; IN: unix.process From 9804d9462de31b3edbaa57dbe355ce0a2a674d22 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 17:33:36 -0600 Subject: [PATCH 37/62] Rename symbols to be consistent --- extra/io/launcher/launcher-docs.factor | 14 +++++++------- extra/io/launcher/launcher.factor | 16 ++++++++-------- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index e372f7a41e..4979f135ac 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -24,11 +24,11 @@ $nl HELP: +environment-mode+ { $description "Launch descriptor key. Must equal of the following:" { $list - { $link prepend-environment } - { $link replace-environment } - { $link append-environment } + { $link +prepend-environment+ } + { $link +replace-environment+ } + { $link +append-environment+ } } -"Default value is " { $link append-environment } "." +"Default value is " { $link +append-environment+ } "." } ; HELP: +stdin+ @@ -61,17 +61,17 @@ HELP: +stderr+ HELP: +closed+ { $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; -HELP: prepend-environment +HELP: +prepend-environment+ { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence." $nl "This is used in situations where you want to spawn a child process with some default environment variables set, but allowing the user to override these defaults by changing the environment before launching Factor." } ; -HELP: replace-environment +HELP: +replace-environment+ { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key." $nl "This is used in situations where you want full control over a child process environment, perhaps for security or testing." } ; -HELP: append-environment +HELP: +append-environment+ { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the current environment together with the value of the " { $link +environment+ } " key, with entries from the " { $link +environment+ } " key taking precedence." $nl "This is used in situations where you want a spawn child process with some overridden environment variables." } ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 9be90d28de..f2ed59a591 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -35,9 +35,9 @@ SYMBOL: +stdout+ SYMBOL: +stderr+ SYMBOL: +closed+ -SYMBOL: prepend-environment -SYMBOL: replace-environment -SYMBOL: append-environment +SYMBOL: +prepend-environment+ +SYMBOL: +replace-environment+ +SYMBOL: +append-environment+ : default-descriptor H{ @@ -45,7 +45,7 @@ SYMBOL: append-environment { +arguments+ f } { +detached+ f } { +environment+ H{ } } - { +environment-mode+ append-environment } + { +environment-mode+ +append-environment+ } } ; : with-descriptor ( desc quot -- ) @@ -53,14 +53,14 @@ SYMBOL: append-environment : pass-environment? ( -- ? ) +environment+ get assoc-empty? not - +environment-mode+ get replace-environment eq? or ; + +environment-mode+ get +replace-environment+ eq? or ; : get-environment ( -- env ) +environment+ get +environment-mode+ get { - { prepend-environment [ os-envs union ] } - { append-environment [ os-envs swap union ] } - { replace-environment [ ] } + { +prepend-environment+ [ os-envs union ] } + { +append-environment+ [ os-envs swap union ] } + { +replace-environment+ [ ] } } case ; GENERIC: >descriptor ( desc -- desc ) From f8df69d9a119967ea723a6924829da6a44dba210 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:00:24 -0600 Subject: [PATCH 38/62] Rename io.monitor to io.monitors; add log-viewer demo --- extra/help/handbook/handbook.factor | 4 ++-- extra/io/{monitor => monitors}/authors.txt | 0 .../monitors-docs.factor} | 14 +++++++------- .../monitor.factor => monitors/monitors.factor} | 2 +- extra/io/{monitor => monitors}/summary.txt | 0 extra/io/unix/linux/linux.factor | 2 +- .../windows/nt/{monitor => monitors}/authors.txt | 0 .../monitor.factor => monitors/monitors.factor} | 7 +++---- extra/io/windows/nt/nt.factor | 2 +- extra/log-viewer/authors.txt | 1 + extra/log-viewer/log-viewer.factor | 14 ++++++++++++++ extra/log-viewer/summary.txt | 1 + extra/log-viewer/tags.txt | 1 + 13 files changed, 32 insertions(+), 16 deletions(-) rename extra/io/{monitor => monitors}/authors.txt (100%) rename extra/io/{monitor/monitor-docs.factor => monitors/monitors-docs.factor} (87%) rename extra/io/{monitor/monitor.factor => monitors/monitors.factor} (94%) rename extra/io/{monitor => monitors}/summary.txt (100%) rename extra/io/windows/nt/{monitor => monitors}/authors.txt (100%) rename extra/io/windows/nt/{monitor/monitor.factor => monitors/monitors.factor} (94%) create mode 100755 extra/log-viewer/authors.txt create mode 100755 extra/log-viewer/log-viewer.factor create mode 100755 extra/log-viewer/summary.txt create mode 100755 extra/log-viewer/tags.txt diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 234e7891d7..81e4bea7b3 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -137,7 +137,7 @@ ARTICLE: "collections" "Collections" { $subsection "graphs" } { $subsection "buffers" } ; -USING: io.sockets io.launcher io.mmap io.monitor ; +USING: io.sockets io.launcher io.mmap io.monitors ; ARTICLE: "io" "Input and output" { $subsection "streams" } @@ -155,7 +155,7 @@ ARTICLE: "io" "Input and output" "Advanced features:" { $subsection "io.launcher" } { $subsection "io.mmap" } -{ $subsection "io.monitor" } ; +{ $subsection "io.monitors" } ; ARTICLE: "tools" "Developer tools" { $subsection "tools.annotations" } diff --git a/extra/io/monitor/authors.txt b/extra/io/monitors/authors.txt similarity index 100% rename from extra/io/monitor/authors.txt rename to extra/io/monitors/authors.txt diff --git a/extra/io/monitor/monitor-docs.factor b/extra/io/monitors/monitors-docs.factor similarity index 87% rename from extra/io/monitor/monitor-docs.factor rename to extra/io/monitors/monitors-docs.factor index de649f48e7..9d985ff3fb 100755 --- a/extra/io/monitor/monitor-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -1,4 +1,4 @@ -IN: io.monitor +IN: io.monitors USING: help.markup help.syntax continuations ; HELP: @@ -9,7 +9,7 @@ $nl HELP: next-change { $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a change descriptor" } } -{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitor.descriptors" } "." } ; +{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ; HELP: with-monitor { $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } } @@ -27,7 +27,7 @@ HELP: +modify-file+ HELP: +rename-file+ { $description "Indicates that file has been renamed." } ; -ARTICLE: "io.monitor.descriptors" "File system change descriptors" +ARTICLE: "io.monitors.descriptors" "File system change descriptors" "Change descriptors output by " { $link next-change } ":" { $subsection +add-file+ } { $subsection +remove-file+ } @@ -35,24 +35,24 @@ ARTICLE: "io.monitor.descriptors" "File system change descriptors" { $subsection +rename-file+ } { $subsection +add-file+ } ; -ARTICLE: "io.monitor" "File system change monitors" +ARTICLE: "io.monitors" "File system change monitors" "File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored." $nl "Creating a file system change monitor and listening for changes:" { $subsection } { $subsection next-change } -{ $subsection "io.monitor.descriptors" } +{ $subsection "io.monitors.descriptors" } "Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "." $nl "A utility combinator which opens a monitor and cleans it up after:" { $subsection with-monitor } "An example which watches the Factor directory for changes:" { $code - "USE: io.monitor" + "USE: io.monitors" ": watch-loop ( monitor -- )" " dup next-change . . nl nl flush watch-loop ;" "" "\"\" resource-path f [ watch-loop ] with-monitor" } ; -ABOUT: "io.monitor" +ABOUT: "io.monitors" diff --git a/extra/io/monitor/monitor.factor b/extra/io/monitors/monitors.factor similarity index 94% rename from extra/io/monitor/monitor.factor rename to extra/io/monitors/monitors.factor index 1d8499b392..d652f34f1e 100755 --- a/extra/io/monitor/monitor.factor +++ b/extra/io/monitors/monitors.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.backend kernel continuations namespaces sequences assocs hashtables sorting arrays ; -IN: io.monitor +IN: io.monitors ( path recursive? -- monitor ) FILE_NOTIFY_INFORMATION-FileName FILE_NOTIFY_INFORMATION-FileNameLength FILE_NOTIFY_INFORMATION-Action - } get-slots parse-action 1array swap - memory>u16-string ; + } get-slots parse-action 1array -rot memory>u16-string ; : (changed-files) ( buffer -- ) dup parse-file-notify changed-file diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index 5bdefd7713..b957aa2fca 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -5,7 +5,7 @@ USE: io.windows USE: io.windows.nt.backend USE: io.windows.nt.files USE: io.windows.nt.launcher -USE: io.windows.nt.monitor +USE: io.windows.nt.monitors USE: io.windows.nt.sockets USE: io.windows.mmap USE: io.backend diff --git a/extra/log-viewer/authors.txt b/extra/log-viewer/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/log-viewer/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/log-viewer/log-viewer.factor b/extra/log-viewer/log-viewer.factor new file mode 100755 index 0000000000..0f139d184e --- /dev/null +++ b/extra/log-viewer/log-viewer.factor @@ -0,0 +1,14 @@ +USING: kernel io io.files io.monitors ; +IN: log-viewer + +: read-lines ( stream -- ) + dup stream-readln dup + [ print read-lines ] [ 2drop flush ] if ; + +: tail-file-loop ( stream monitor -- ) + dup next-change 2drop over read-lines tail-file-loop ; + +: tail-file ( file -- ) + dup dup read-lines + swap parent-directory f + tail-file-loop ; diff --git a/extra/log-viewer/summary.txt b/extra/log-viewer/summary.txt new file mode 100755 index 0000000000..5eb102447a --- /dev/null +++ b/extra/log-viewer/summary.txt @@ -0,0 +1 @@ +Simple log file watcher demo using io.monitors diff --git a/extra/log-viewer/tags.txt b/extra/log-viewer/tags.txt new file mode 100755 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/log-viewer/tags.txt @@ -0,0 +1 @@ +demos From 20e4fcecda6d3b2a2d20756ae002fa85c19a1b34 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:48:38 -0600 Subject: [PATCH 39/62] Make OS name more consistent for extra/builder --- Makefile | 8 ++++---- core/system/system-docs.factor | 3 ++- core/system/system.factor | 2 +- vm/os-windows-nt.h | 2 +- 4 files changed, 8 insertions(+), 7 deletions(-) mode change 100644 => 100755 core/system/system-docs.factor mode change 100644 => 100755 core/system/system.factor diff --git a/Makefile b/Makefile index aad7fe90eb..5e1a9d6220 100755 --- a/Makefile +++ b/Makefile @@ -63,8 +63,8 @@ default: @echo "macosx-ppc" @echo "solaris-x86-32" @echo "solaris-x86-64" - @echo "windows-ce-arm" - @echo "windows-nt-x86-32" + @echo "wince-arm" + @echo "winnt-x86-32" @echo "" @echo "Additional modifiers:" @echo "" @@ -122,10 +122,10 @@ solaris-x86-32: solaris-x86-64: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64 -windows-nt-x86-32: +winnt-x86-32: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 -windows-ce-arm: +wince-arm: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm macosx.app: factor diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor old mode 100644 new mode 100755 index d80cfa9ceb..bdd04307df --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -51,7 +51,8 @@ HELP: os "openbsd" "netbsd" "solaris" - "windows" + "wince" + "winnt" } } ; diff --git a/core/system/system.factor b/core/system/system.factor old mode 100644 new mode 100755 index 4983260a36..4500720058 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -22,7 +22,7 @@ splitting assocs ; os "wince" = ; foldable : winnt? ( -- ? ) - os "windows" = ; foldable + os "winnt" = ; foldable : windows? ( -- ? ) wince? winnt? or ; foldable diff --git a/vm/os-windows-nt.h b/vm/os-windows-nt.h index 9e451f0301..e289b6617d 100755 --- a/vm/os-windows-nt.h +++ b/vm/os-windows-nt.h @@ -12,7 +12,7 @@ typedef char F_SYMBOL; #define unbox_symbol_string unbox_char_string #define from_symbol_string from_char_string -#define FACTOR_OS_STRING "windows" +#define FACTOR_OS_STRING "winnt" #define FACTOR_DLL L"factor-nt.dll" #define FACTOR_DLL_NAME "factor-nt.dll" From cf99e405fe22f35900160fc054d401894f101d69 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:50:24 -0600 Subject: [PATCH 40/62] More intuitive error message for about --- extra/help/help.factor | 3 +++ 1 file changed, 3 insertions(+) mode change 100644 => 100755 extra/help/help.factor diff --git a/extra/help/help.factor b/extra/help/help.factor old mode 100644 new mode 100755 index 87bc0a4b7f..aefbf2aba2 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -96,6 +96,9 @@ M: word set-article-parent swap "help-parent" set-word-prop ; article-content print-content nl ; : about ( vocab -- ) + dup vocab [ ] [ + "No such vocabulary: " swap append throw + ] ?if dup vocab-help [ help ] [ From 551b3a42a130eaf0e0ea77e1b9ba873c5e5628db Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:52:16 -0600 Subject: [PATCH 41/62] New reset-memoized word --- extra/memoize/memoize.factor | 3 +++ extra/xmode/catalog/catalog.factor | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) mode change 100644 => 100755 extra/xmode/catalog/catalog.factor diff --git a/extra/memoize/memoize.factor b/extra/memoize/memoize.factor index 5fa112921c..3b0b8fd29f 100755 --- a/extra/memoize/memoize.factor +++ b/extra/memoize/memoize.factor @@ -50,3 +50,6 @@ M: memoized definition "memo-quot" word-prop ; : memoize-quot ( quot effect -- memo-quot ) gensym swap dupd "declared-effect" set-word-prop dup rot define-memoized 1quotation ; + +: reset-memoized ( word -- ) + "memoize" word-prop clear-assoc ; diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor old mode 100644 new mode 100755 index 9c7e6a1ee7..d6402603fa --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -99,7 +99,7 @@ SYMBOL: rule-sets (load-mode) dup finalize-mode ; : reset-modes ( -- ) - \ (load-mode) "memoize" word-prop clear-assoc ; + \ (load-mode) reset-memoized ; : ?glob-matches ( string glob/f -- ? ) dup [ glob-matches? ] [ 2drop f ] if ; From 18403d15faf04ade5a159672585fdb4f68a12bff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:55:10 -0600 Subject: [PATCH 42/62] tools.browser now uses io.monitor --- extra/tools/browser/browser-docs.factor | 22 ++++++++++-- extra/tools/browser/browser.factor | 47 ++++++++++++++++++------- extra/vocabs/monitor/authors.txt | 1 + extra/vocabs/monitor/monitor.factor | 14 ++++++++ extra/vocabs/monitor/summary.txt | 1 + 5 files changed, 71 insertions(+), 14 deletions(-) mode change 100644 => 100755 extra/tools/browser/browser-docs.factor create mode 100644 extra/vocabs/monitor/authors.txt create mode 100755 extra/vocabs/monitor/monitor.factor create mode 100644 extra/vocabs/monitor/summary.txt diff --git a/extra/tools/browser/browser-docs.factor b/extra/tools/browser/browser-docs.factor old mode 100644 new mode 100755 index db0e5942f5..28bef58a8a --- a/extra/tools/browser/browser-docs.factor +++ b/extra/tools/browser/browser-docs.factor @@ -2,16 +2,34 @@ USING: help.markup help.syntax io strings ; IN: tools.browser ARTICLE: "vocab-index" "Vocabulary index" -{ $tags,authors } +{ $tags } +{ $authors } { $describe-vocab "" } ; ARTICLE: "tools.browser" "Vocabulary browser" "Getting and setting vocabulary meta-data:" +{ $subsection vocab-file-contents } +{ $subsection set-vocab-file-contents } { $subsection vocab-summary } { $subsection set-vocab-summary } { $subsection vocab-tags } { $subsection set-vocab-tags } -{ $subsection add-vocab-tags } ; +{ $subsection add-vocab-tags } +"Global meta-data:" +{ $subsection all-vocabs } +{ $subsection all-vocabs-seq } +{ $subsection all-tags } +{ $subsection all-authors } +"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:" +{ $subsection reset-cache } ; + +HELP: vocab-file-contents +{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } } +{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-file-contents +{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } } +{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ; HELP: vocab-summary { $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } } diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index dabc37e5de..7aefbc8aaa 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -1,13 +1,30 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces splitting sequences io.files kernel assocs words vocabs vocabs.loader definitions parser continuations inspector debugger io io.styles io.streams.lines hashtables sorting prettyprint source-files arrays combinators strings system math.parser help.markup help.topics help.syntax -help.stylesheet ; +help.stylesheet memoize ; IN: tools.browser +MEMO: (vocab-file-contents) ( path -- lines ) + ?resource-path dup exists? + [ lines ] [ drop f ] if ; + +: vocab-file-contents ( vocab name -- seq ) + vocab-path+ dup [ (vocab-file-contents) ] when ; + +: set-vocab-file-contents ( seq vocab name -- ) + dupd vocab-path+ [ + ?resource-path + [ [ print ] each ] with-stream + ] [ + "The " swap vocab-name + " vocabulary was not loaded from the file system" + 3append throw + ] ?if ; + : vocab-summary-path ( vocab -- string ) vocab-dir "summary.txt" path+ ; @@ -86,7 +103,7 @@ M: vocab-link summary vocab-summary ; dup [ "" vocabs-in-dir ] { } make ] { } map>assoc ; -: all-vocabs-seq ( -- seq ) +MEMO: all-vocabs-seq ( -- seq ) all-vocabs values concat ; : dangerous? ( name -- ? ) @@ -288,20 +305,20 @@ C: vocab-author : $tagged-vocabs ( element -- ) first tagged vocabs. ; -: all-tags ( vocabs -- seq ) [ vocab-tags ] map>set ; +MEMO: all-tags ( -- seq ) + all-vocabs-seq [ vocab-tags ] map>set ; : $authored-vocabs ( element -- ) first authored vocabs. ; -: all-authors ( vocabs -- seq ) [ vocab-authors ] map>set ; +MEMO: all-authors ( -- seq ) + all-vocabs-seq [ vocab-authors ] map>set ; -: $tags,authors ( element -- ) - drop - all-vocabs-seq - "Tags" $heading - dup all-tags tags. - "Authors" $heading - all-authors authors. ; +: $tags ( element -- ) + drop "Tags" $heading all-tags tags. ; + +: $authors ( element -- ) + drop "Authors" $heading all-authors authors. ; M: vocab-spec article-title vocab-name " vocabulary" append ; @@ -339,3 +356,9 @@ M: vocab-author article-content M: vocab-author article-parent drop "vocab-index" ; M: vocab-author summary article-title ; + +: reset-cache ( -- ) + \ (vocab-file-contents) reset-memoized + \ all-vocabs-seq reset-memoized + \ all-authors reset-memoized + \ all-tags reset-memoized ; diff --git a/extra/vocabs/monitor/authors.txt b/extra/vocabs/monitor/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/vocabs/monitor/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/vocabs/monitor/monitor.factor b/extra/vocabs/monitor/monitor.factor new file mode 100755 index 0000000000..24aa8b1d99 --- /dev/null +++ b/extra/vocabs/monitor/monitor.factor @@ -0,0 +1,14 @@ +USING: threads io.files io.monitors init kernel tools.browser ; +IN: vocabs.monitor + +! Use file system change monitoring to flush the tags/authors +! cache +: update-thread ( monitor -- ) + dup next-change 2drop reset-cache update-thread ; + +: start-update-thread + [ + "" resource-path t update-thread + ] in-thread ; + +[ start-update-thread ] "tools.browser" add-init-hook diff --git a/extra/vocabs/monitor/summary.txt b/extra/vocabs/monitor/summary.txt new file mode 100644 index 0000000000..27c0d3867a --- /dev/null +++ b/extra/vocabs/monitor/summary.txt @@ -0,0 +1 @@ +Use io.monitors to clear tools.browser authors/tags/summary cache From c87bd84635ed8c984f2cd9d87ef0e14b6711adef Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:55:20 -0600 Subject: [PATCH 43/62] Fix opengl tags --- extra/opengl/tags.txt | 3 --- 1 file changed, 3 deletions(-) mode change 100644 => 100755 extra/opengl/tags.txt diff --git a/extra/opengl/tags.txt b/extra/opengl/tags.txt old mode 100644 new mode 100755 index 5e477dbcb3..bb863cf9a0 --- a/extra/opengl/tags.txt +++ b/extra/opengl/tags.txt @@ -1,4 +1 @@ -opengl.glu -opengl.gl -opengl bindings From 687cd7860321ac07a36f0c6d96b1c1cd946099b6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:55:28 -0600 Subject: [PATCH 44/62] Word moved --- extra/tools/deploy/config/config.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor index e6d03c2233..1f34e68f29 100755 --- a/extra/tools/deploy/config/config.factor +++ b/extra/tools/deploy/config/config.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: vocabs.loader io.files io kernel sequences assocs splitting parser prettyprint namespaces math vocabs -hashtables ; +hashtables tools.browser ; IN: tools.deploy.config SYMBOL: deploy-name From 038578939f998bcdce47e47980cf019e3971105b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 19:01:19 -0600 Subject: [PATCH 45/62] Change require-all for Ed --- core/vocabs/loader/loader-docs.factor | 13 +++---- core/vocabs/loader/loader.factor | 50 ++++++++++++--------------- extra/bootstrap/io/io.factor | 2 ++ 3 files changed, 30 insertions(+), 35 deletions(-) diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index 899d50407f..bc88661530 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -124,15 +124,12 @@ HELP: refresh { $values { "prefix" string } } { $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; +HELP: refresh-all-error +{ $values { "vocabs" "a sequence of vocabularies" } } +{ $description "Throws a " { $link require-all-error } "." } +{ $error-description "Thrown by " { $link require-all } " if one or more vocabulary failed to load." } ; + HELP: refresh-all { $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ; { refresh refresh-all } related-words - -HELP: vocab-file-contents -{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } } -{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-file-contents -{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } } -{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index f2c5b2a012..6e6d1923e0 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -148,16 +148,31 @@ SYMBOL: load-help? dup update-roots dup modified-sources swap modified-docs ; -: require-restart { { "Ignore this vocabulary" t } } ; +: load-error. ( vocab error -- ) + "While loading " swap dup >vocab-link write-object ":" print + print-error ; -: require-all ( seq -- ) - [ +TUPLE: require-all-error vocabs ; + +: require-all-error ( vocabs -- ) + \ require-all-error construct-boa throw ; + +M: require-all-error summary + drop "The require-all operation failed" ; + +: require-all ( vocabs -- ) + dup length 1 = [ first require ] [ [ - [ require ] - [ require-restart rethrow-restarts 2drop ] - recover - ] each - ] with-compiler-errors ; + [ + [ [ require ] [ 2array , ] recover ] each + ] { } make + dup empty? [ drop ] [ + "==== LOAD ERRORS:" print + dup [ nl load-error. ] assoc-each + keys require-all-error + ] if + ] with-compiler-errors + ] if ; : do-refresh ( modified-sources modified-docs -- ) 2dup @@ -190,22 +205,3 @@ load-vocab-hook set-global M: vocab where vocab-where ; M: vocab-link where vocab-where ; - -: vocab-file-contents ( vocab name -- seq ) - vocab-path+ dup [ - ?resource-path dup exists? [ - lines - ] [ - drop f - ] if - ] when ; - -: set-vocab-file-contents ( seq vocab name -- ) - dupd vocab-path+ [ - ?resource-path - [ [ print ] each ] with-stream - ] [ - "The " swap vocab-name - " vocabulary was not loaded from the file system" - 3append throw - ] ?if ; diff --git a/extra/bootstrap/io/io.factor b/extra/bootstrap/io/io.factor index 065f7dd5c4..4d5440e546 100755 --- a/extra/bootstrap/io/io.factor +++ b/extra/bootstrap/io/io.factor @@ -10,3 +10,5 @@ IN: bootstrap.io { [ wince? ] [ "windows.ce" ] } } cond append require ] when + +"vocabs.monitor" require From 1eda70f1ad1f0d744ed846ce8c975a1cd4b28fb6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 19:16:22 -0600 Subject: [PATCH 46/62] Bug fixes --- core/io/files/files.factor | 13 ++++++++----- core/vocabs/loader/loader-docs.factor | 2 +- core/vocabs/loader/loader.factor | 2 +- extra/io/windows/nt/files/files.factor | 12 +++++++++--- extra/io/windows/nt/nt-tests.factor | 22 +++++++++++++++++++--- 5 files changed, 38 insertions(+), 13 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 9952e6387b..9a99090699 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -29,12 +29,15 @@ HOOK: root-directory? io-backend ( path -- ? ) M: object root-directory? ( path -- ? ) path-separator? ; -: trim-path-separators ( str -- newstr ) +: right-trim-separators ( str -- newstr ) [ path-separator? ] right-trim ; +: left-trim-separators ( str -- newstr ) + [ path-separator? ] left-trim ; + : path+ ( str1 str2 -- str ) - >r trim-path-separators "/" r> - [ path-separator? ] left-trim 3append ; + >r right-trim-separators "/" r> + left-trim-separators 3append ; : stat ( path -- directory? permissions length modified ) normalize-pathname (stat) ; @@ -69,7 +72,7 @@ TUPLE: no-parent-directory path ; \ no-parent-directory construct-boa throw ; : parent-directory ( path -- parent ) - trim-path-separators { + right-trim-separators { { [ dup empty? ] [ drop "/" ] } { [ dup root-directory? ] [ ] } { [ dup [ path-separator? ] contains? not ] [ drop "." ] } @@ -90,7 +93,7 @@ TUPLE: no-parent-directory path ; "resource:" ?head [ resource-path ] when ; : make-directories ( path -- ) - normalize-pathname trim-path-separators { + normalize-pathname right-trim-separators { { [ dup "." = ] [ ] } { [ dup root-directory? ] [ ] } { [ dup empty? ] [ ] } diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index bc88661530..f8626f3370 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -124,7 +124,7 @@ HELP: refresh { $values { "prefix" string } } { $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; -HELP: refresh-all-error +HELP: require-all-error { $values { "vocabs" "a sequence of vocabularies" } } { $description "Throws a " { $link require-all-error } "." } { $error-description "Thrown by " { $link require-all } " if one or more vocabulary failed to load." } ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 6e6d1923e0..64372fe4b7 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -149,7 +149,7 @@ SYMBOL: load-help? dup modified-sources swap modified-docs ; : load-error. ( vocab error -- ) - "While loading " swap dup >vocab-link write-object ":" print + "While loading " rot dup >vocab-link write-object ":" print print-error ; TUPLE: require-all-error vocabs ; diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 5cbcd063bd..a1c331816c 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -37,11 +37,13 @@ M: windows-nt-io root-directory? ( path -- ? ) : windows-path+ ( cwd path -- newpath ) { ! empty - { [ dup empty? ] [ "empty path" throw ] } + { [ dup empty? ] [ drop ] } + ! .. + { [ dup ".." = ] [ drop parent-directory prepend-prefix ] } ! \\\\?\\c:\\foo { [ dup unicode-prefix head? ] [ nip ] } ! ..\\foo - { [ dup "..\\" head? ] [ >r parent-directory r> 2 tail windows-path+ ] } + { [ dup "..\\" head? ] [ >r parent-directory r> 3 tail windows-path+ ] } ! .\\foo { [ dup ".\\" head? ] [ 1 tail append prepend-prefix ] } ! \\foo @@ -49,7 +51,11 @@ M: windows-nt-io root-directory? ( path -- ? ) ! c:\\foo { [ dup ?second CHAR: : = ] [ nip prepend-prefix ] } ! foo.txt - { [ t ] [ [ first CHAR: \\ = "" "\\" ? ] keep 3append prepend-prefix ] } + { [ t ] [ + >r right-trim-separators "\\" r> + left-trim-separators + 3append prepend-prefix + ] } } cond ; M: windows-nt-io normalize-pathname ( string -- string ) diff --git a/extra/io/windows/nt/nt-tests.factor b/extra/io/windows/nt/nt-tests.factor index ad409fb083..e4ebe3dd37 100755 --- a/extra/io/windows/nt/nt-tests.factor +++ b/extra/io/windows/nt/nt-tests.factor @@ -1,4 +1,5 @@ -USING: io.files kernel tools.test io.backend splitting ; +USING: io.files kernel tools.test io.backend +io.windows.nt.files splitting ; IN: temporary [ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test @@ -9,8 +10,8 @@ IN: temporary [ "Z:" ] [ "Z:\\" parent-directory ] unit-test [ "c:" ] [ "c:" parent-directory ] unit-test [ "Z:" ] [ "Z:" parent-directory ] unit-test -[ t ] [ "c:\\" trim-path-separators root-directory? ] unit-test -[ t ] [ "Z:\\" trim-path-separators root-directory? ] unit-test +[ t ] [ "c:\\" right-trim-separators root-directory? ] unit-test +[ t ] [ "Z:\\" right-trim-separators root-directory? ] unit-test [ f ] [ "c:\\foo" root-directory? ] unit-test [ f ] [ "." root-directory? ] unit-test [ f ] [ ".." root-directory? ] unit-test @@ -18,3 +19,18 @@ IN: temporary [ ] [ "" resource-path cd ] unit-test [ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test + +[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [ + "C:\\builds\\factor\\12345\\" + "..\\log.txt" windows-path+ +] unit-test + +[ "\\\\?\\C:\\builds\\" ] [ + "C:\\builds\\factor\\12345\\" + "..\\.." windows-path+ +] unit-test + +[ "\\\\?\\C:\\builds\\" ] [ + "C:\\builds\\factor\\12345\\" + "..\\.." windows-path+ +] unit-test From 3f9e4bcf0025c03e5a1f3ad0630e8a85f9d3410a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 20:11:35 -0600 Subject: [PATCH 47/62] More efficient specializers --- core/generator/generator.factor | 5 ++- core/optimizer/backend/backend.factor | 6 +-- core/optimizer/known-words/known-words.factor | 16 +++---- core/optimizer/optimizer-docs.factor | 29 ------------- core/optimizer/optimizer.factor | 43 +------------------ .../specializers/specializers-docs.factor | 26 +++++++++++ .../specializers/specializers.factor | 41 ++++++++++++++++++ extra/benchmark/recursive/recursive.factor | 6 --- extra/math/vectors/vectors.factor | 30 ++++++------- 9 files changed, 98 insertions(+), 104 deletions(-) mode change 100644 => 100755 core/optimizer/optimizer-docs.factor mode change 100644 => 100755 core/optimizer/optimizer.factor create mode 100755 core/optimizer/specializers/specializers-docs.factor create mode 100755 core/optimizer/specializers/specializers.factor mode change 100644 => 100755 extra/benchmark/recursive/recursive.factor diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 3d66241bc3..3883fb6e35 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -3,8 +3,9 @@ USING: arrays assocs classes combinators cpu.architecture effects generator.fixup generator.registers generic hashtables inference inference.backend inference.dataflow io kernel -kernel.private layouts math namespaces optimizer prettyprint -quotations sequences system threads words vectors ; +kernel.private layouts math namespaces optimizer +optimizer.specializers prettyprint quotations sequences system +threads words vectors ; IN: generator SYMBOL: compile-queue diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 9d75346091..e73200b861 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -4,7 +4,7 @@ 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.pattern-match generic.standard ; +optimizer.pattern-match generic.standard optimizer.specializers ; IN: optimizer.backend SYMBOL: class-substitutions @@ -256,7 +256,7 @@ M: #dispatch optimize-node* tuck dispatching-class dup [ swap [ 2array ] 2keep method method-word - dup word-def flat-length 6 >= + dup word-def flat-length 5 >= [ 1quotation ] [ word-def ] if ] [ 2drop t t @@ -363,7 +363,7 @@ M: #dispatch optimize-node* : optimistic-inline? ( #call -- ? ) dup node-param "specializer" word-prop dup [ - >r node-input-classes r> length tail* + >r node-input-classes r> specialized-length tail* [ types length 1 = ] all? ] [ 2drop f diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 6828a0948c..5820d8f5b2 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -124,19 +124,19 @@ float-arrays combinators.private combinators ; ] each \ push-all -{ { string array } { sbuf vector } } +{ { string sbuf } { array vector } } "specializer" set-word-prop \ append -{ { string array } { string array } } +{ { string string } { array array } } "specializer" set-word-prop \ subseq -{ fixnum fixnum { string array } } +{ { fixnum fixnum string } { fixnum fixnum array } } "specializer" set-word-prop \ reverse-here -{ { string array } } +{ { string } { array } } "specializer" set-word-prop \ mismatch @@ -147,9 +147,9 @@ float-arrays combinators.private combinators ; \ >string { sbuf } "specializer" set-word-prop -\ >array { { string vector } } "specializer" set-word-prop +\ >array { { string } { vector } } "specializer" set-word-prop -\ >vector { { array vector } } "specializer" set-word-prop +\ >vector { { array } { vector } } "specializer" set-word-prop \ >sbuf { string } "specializer" set-word-prop @@ -163,6 +163,6 @@ float-arrays combinators.private combinators ; \ assoc-stack { vector } "specializer" set-word-prop -\ >le { { fixnum bignum } fixnum } "specializer" set-word-prop +\ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop -\ >be { { fixnum bignum } fixnum } "specializer" set-word-prop +\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop diff --git a/core/optimizer/optimizer-docs.factor b/core/optimizer/optimizer-docs.factor old mode 100644 new mode 100755 index ff694650bc..4be1176cda --- a/core/optimizer/optimizer-docs.factor +++ b/core/optimizer/optimizer-docs.factor @@ -2,31 +2,6 @@ USING: help.markup help.syntax quotations words math sequences ; IN: optimizer -ARTICLE: "specializers" "Word specializers" -"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class." -$nl -"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is a sequence having the same number of elements as the word has inputs; each element takes one of the following forms and gives the compiler a hint about the corresponding parameter:" -{ $table - { { $snippet { $emphasis "class" } } { "a class word indicates that this parameter is expected to be an instance of the class most of the time." } } - { { $snippet "{ " { $emphasis "classes..." } " }" } { "a sequence of class words indicates that this parameter is expected to be an instance of one of these classes most of the time." } } - { { $snippet "number" } { "the " { $link number } " class word has a special behavior. It will result in a version of the word being generated for every primitive numeric type, where this parameter is assumed to have that type. A fast jump table will then determine which version is chosen at run time." } } - { { $snippet "*" } { "indicates no specialization should be performed on this parameter." } } -} -"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place." -$nl -"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information." -$nl -"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class." -$nl -"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:" -{ $code -"\\ append" -"{ { string array } { string array } }" -"\"specializer\" set-word-prop" -} -"The specialized version of a word which will be compiled by the compiler can be inspected:" -{ $subsection specialized-def } ; - ARTICLE: "optimizer" "Optimizer" "The words in the " { $vocab-link "optimizer" } " vocabulary are internal to the compiler and user code has no reason to call them." $nl @@ -43,7 +18,3 @@ HELP: optimize-1 HELP: optimize { $values { "node" "a dataflow graph" } { "newnode" "a dataflow graph" } } { $description "Continues to optimize a dataflow graph until a fixed point is reached." } ; - -HELP: specialized-def -{ $values { "word" word } { "quot" quotation } } -{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ; diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor old mode 100644 new mode 100755 index 66e4ac9220..219b27197f --- a/core/optimizer/optimizer.factor +++ b/core/optimizer/optimizer.factor @@ -1,10 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic hashtables kernel kernel.private math -namespaces sequences vectors words strings layouts combinators -combinators.private classes optimizer.backend optimizer.def-use -optimizer.known-words optimizer.math inference.class -generic.standard ; +USING: kernel namespaces optimizer.backend optimizer.def-use +optimizer.known-words optimizer.math inference.class ; IN: optimizer : optimize-1 ( node -- newnode ? ) @@ -22,39 +19,3 @@ IN: optimizer : optimize ( node -- newnode ) optimize-1 [ optimize ] when ; - -: simple-specializer ( quot dispatch# classes -- quot ) - swap (dispatch#) [ - object add* swap [ 2array ] curry map - object method-alist>quot - ] with-variable ; - -: dispatch-specializer ( quot dispatch# symbol dispatcher -- quot ) - rot (dispatch#) [ - [ - picker % - , - get swap , - \ dispatch , - ] [ ] make - ] with-variable ; - -: tag-specializer ( quot dispatch# -- quot ) - num-tags \ tag dispatch-specializer ; - -: type-specializer ( quot dispatch# -- quot ) - num-types \ type dispatch-specializer ; - -: make-specializer ( quot dispatch# spec -- quot ) - { - { [ dup number eq? ] [ drop tag-specializer ] } - { [ dup object eq? ] [ drop type-specializer ] } - { [ dup \ * eq? ] [ 2drop ] } - { [ dup array? ] [ simple-specializer ] } - { [ t ] [ 1array simple-specializer ] } - } cond ; - -: specialized-def ( word -- quot ) - dup word-def swap "specializer" word-prop [ - [ length ] keep [ make-specializer ] 2each - ] when* ; diff --git a/core/optimizer/specializers/specializers-docs.factor b/core/optimizer/specializers/specializers-docs.factor new file mode 100755 index 0000000000..de5d5d7a1f --- /dev/null +++ b/core/optimizer/specializers/specializers-docs.factor @@ -0,0 +1,26 @@ +IN: optimizer.specializers +USING: help.markup help.syntax sequences words quotations ; + +ARTICLE: "specializers" "Word specializers" +"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class." +$nl +"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is either a sequence of classes, or a sequence of sequences of classes. Each element in the sequence (or the sequence itself, in the former case) is a specialization hint." +$nl +"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place." +$nl +"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information." +$nl +"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class." +$nl +"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:" +{ $code +"\\ append" +"{ { string string } { array array } }" +"\"specializer\" set-word-prop" +} +"The specialized version of a word which will be compiled by the compiler can be inspected:" +{ $subsection specialized-def } ; + +HELP: specialized-def +{ $values { "word" word } { "quot" quotation } } +{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ; diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor new file mode 100755 index 0000000000..223ce18117 --- /dev/null +++ b/core/optimizer/specializers/specializers.factor @@ -0,0 +1,41 @@ +! Copyright (C) 2006, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays generic hashtables kernel kernel.private math +namespaces sequences vectors words strings layouts combinators +combinators.private classes generic.standard assocs ; +IN: optimizer.specializers + +: (make-specializer) ( class picker -- quot ) + swap "predicate" word-prop append ; + +: make-specializer ( classes -- quot ) + dup length + [ (picker) 2array ] 2map + [ drop object eq? not ] assoc-subset + dup empty? [ drop [ t ] ] [ + [ (make-specializer) ] { } assoc>map + unclip [ swap [ f ] \ if 3array append [ ] like ] reduce + ] if ; + +: tag-specializer ( quot -- newquot ) + [ + [ dup tag ] % + num-tags get swap , + \ dispatch , + ] [ ] make ; + +: specialized-def ( word -- quot ) + dup word-def swap "specializer" word-prop [ + dup { number } = [ + drop tag-specializer + ] [ + dup [ array? ] all? [ 1array ] unless [ + [ make-specializer ] keep + [ declare ] curry pick append + ] { } map>assoc + alist>quot + ] if + ] when* ; + +: specialized-length ( specializer -- n ) + dup [ array? ] all? [ first ] when length ; diff --git a/extra/benchmark/recursive/recursive.factor b/extra/benchmark/recursive/recursive.factor old mode 100644 new mode 100755 index 79c6dfbaca..6e3c201cf0 --- a/extra/benchmark/recursive/recursive.factor +++ b/extra/benchmark/recursive/recursive.factor @@ -4,8 +4,6 @@ USING: math kernel hints prettyprint io ; : fib ( m -- n ) dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; -! HINTS: fib { fixnum float } ; -! : ack ( m n -- x ) over zero? [ nip 1+ @@ -17,8 +15,6 @@ USING: math kernel hints prettyprint io ; ] if ] if ; -! HINTS: ack fixnum fixnum ; - : tak ( x y z -- t ) pick pick swap < [ [ rot 1- -rot tak ] 3keep @@ -29,8 +25,6 @@ USING: math kernel hints prettyprint io ; 2nip ] if ; -! HINTS: tak { fixnum float } { fixnum float } { fixnum float } ; - : recursive ( n -- ) 3 over ack . flush dup 27.0 + fib . flush diff --git a/extra/math/vectors/vectors.factor b/extra/math/vectors/vectors.factor index b2a8995df0..2be9cf7f58 100755 --- a/extra/math/vectors/vectors.factor +++ b/extra/math/vectors/vectors.factor @@ -27,20 +27,20 @@ IN: math.vectors : set-axis ( u v axis -- w ) dup length [ >r zero? pick pick ? r> swap nth ] 2map 2nip ; -HINTS: vneg { float-array array } ; -HINTS: norm-sq { float-array array } ; -HINTS: norm { float-array array } ; -HINTS: normalize { float-array array } ; +HINTS: vneg { float-array } { array } ; +HINTS: norm-sq { float-array } { array } ; +HINTS: norm { float-array } { array } ; +HINTS: normalize { float-array } { array } ; -HINTS: n*v * { float-array array } ; -HINTS: v*n { float-array array } * ; -HINTS: n/v * { float-array array } ; -HINTS: v/n { float-array array } * ; +HINTS: n*v { object float-array } { object array } ; +HINTS: v*n { float-array object } { array object } ; +HINTS: n/v { object float-array } { array } ; +HINTS: v/n { float-array object } { array object } ; -HINTS: v+ { float-array array } { float-array array } ; -HINTS: v- { float-array array } { float-array array } ; -HINTS: v* { float-array array } { float-array array } ; -HINTS: v/ { float-array array } { float-array array } ; -HINTS: vmax { float-array array } { float-array array } ; -HINTS: vmin { float-array array } { float-array array } ; -HINTS: v. { float-array array } { float-array array } ; +HINTS: v+ { float-array float-array } { array array } ; +HINTS: v- { float-array float-array } { array array } ; +HINTS: v* { float-array float-array } { array array } ; +HINTS: v/ { float-array float-array } { array array } ; +HINTS: vmax { float-array float-array } { array array } ; +HINTS: vmin { float-array float-array } { array array } ; +HINTS: v. { float-array float-array } { array array } ; From 95651daef07cea2485add25be8791f957b67dc86 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 22:36:10 -0600 Subject: [PATCH 48/62] Faster parser --- core/parser/parser-docs.factor | 6 ---- core/parser/parser.factor | 47 +++++++++++++++++--------------- extra/multiline/multiline.factor | 4 +-- 3 files changed, 27 insertions(+), 30 deletions(-) mode change 100644 => 100755 extra/multiline/multiline.factor diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index d8d6c9b7bc..ae38925c68 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -136,8 +136,6 @@ ARTICLE: "parser-lexer" "The lexer" { $subsection } "A word to test of the end of input has been reached:" { $subsection still-parsing? } -"A word to get the text of the current line:" -{ $subsection line-text } "A word to advance the lexer to the next line:" { $subsection next-line } "Two generic words to override the lexer's token boundary detection:" @@ -222,10 +220,6 @@ HELP: { $values { "msg" "an error" } { "error" parse-error } } { $description "Creates a new " { $link parse-error } ", filling in the location information from the current " { $link lexer } "." } ; -HELP: line-text -{ $values { "lexer" lexer } { "str" string } } -{ $description "Outputs the text of the line being parsed." } ; - HELP: skip { $values { "i" "a starting index" } { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "n" integer } } { $description "Variant of " { $link find* } " that outputs the length of the sequence instead of " { $link f } " if no elements satisfy the predicate." } ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 6d7ad47843..59d18dc734 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -8,12 +8,17 @@ io.files io.streams.string io.streams.lines vocabs source-files classes hashtables compiler.errors compiler.units ; IN: parser -TUPLE: lexer text line column ; +TUPLE: lexer text line line-text line-length column ; -: ( text -- lexer ) 1 0 lexer construct-boa ; +: next-line ( lexer -- ) + 0 over set-lexer-column + dup lexer-line over lexer-text ?nth over set-lexer-line-text + dup lexer-line-text length over set-lexer-line-length + dup lexer-line 1+ swap set-lexer-line ; -: line-text ( lexer -- str ) - dup lexer-line 1- swap lexer-text ?nth ; +: ( text -- lexer ) + 0 { set-lexer-text set-lexer-line } lexer construct + dup lexer-text empty? [ dup next-line ] unless ; : location ( -- loc ) file get lexer get lexer-line 2dup and @@ -50,18 +55,14 @@ t parser-notes set-global "Note: " write dup print ] when drop ; -: next-line ( lexer -- ) - 0 over set-lexer-column - dup lexer-line 1+ swap set-lexer-line ; - : skip ( i seq ? -- n ) over >r [ swap CHAR: \s eq? xor ] curry find* drop - [ r> drop ] [ r> length ] if* ; inline + [ r> drop ] [ r> length ] if* ; : change-column ( lexer quot -- ) swap - [ dup lexer-column swap line-text rot call ] keep + [ dup lexer-column swap lexer-line-text rot call ] keep set-lexer-column ; inline GENERIC: skip-blank ( lexer -- ) @@ -73,20 +74,20 @@ GENERIC: skip-word ( lexer -- ) M: lexer skip-word ( lexer -- ) [ - 2dup nth CHAR: " = [ drop 1+ ] [ f skip ] if + 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if ] change-column ; : still-parsing? ( lexer -- ? ) dup lexer-line swap lexer-text length <= ; : still-parsing-line? ( lexer -- ? ) - dup lexer-column swap line-text length < ; + dup lexer-column swap lexer-line-length < ; : (parse-token) ( lexer -- str ) [ lexer-column ] keep [ skip-word ] keep [ lexer-column ] keep - line-text subseq ; + lexer-line-text subseq ; : parse-token ( lexer -- str/f ) dup still-parsing? [ @@ -139,9 +140,8 @@ TUPLE: parse-error file line col text ; : ( msg -- error ) file get - lexer get lexer-line - lexer get lexer-column - lexer get line-text + lexer get + { lexer-line lexer-column lexer-line-text } get-slots parse-error construct-boa [ set-delegate ] keep ; @@ -239,22 +239,25 @@ M: no-word summary word-restarts throw-restarts dup word-vocabulary (use+) ; -: check-forward ( str word -- word ) +: check-forward ( str word -- word/f ) dup forward-reference? [ drop - dup use get + use get [ at ] with map [ ] subset [ forward-reference? not ] find nip - [ ] [ no-word ] ?if ] [ nip ] if ; -: search ( str -- word ) - dup use get assoc-stack [ check-forward ] [ no-word ] if* ; +: search ( str -- word/f ) + dup use get assoc-stack check-forward ; : scan-word ( -- word/number/f ) - scan dup [ dup string>number [ ] [ search ] ?if ] when ; + scan dup [ + dup search [ ] [ + dup string>number [ ] [ no-word ] ?if + ] ?if + ] when ; TUPLE: staging-violation word ; diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor old mode 100644 new mode 100755 index 7f831e5351..9a6d052b60 --- a/extra/multiline/multiline.factor +++ b/extra/multiline/multiline.factor @@ -4,7 +4,7 @@ USING: namespaces parser kernel sequences words quotations math ; IN: multiline : next-line-text ( -- str ) - lexer get dup next-line line-text ; + lexer get dup next-line lexer-line-text ; : (parse-here) ( -- ) next-line-text dup ";" = @@ -19,7 +19,7 @@ IN: multiline parse-here 1quotation define ; parsing : (parse-multiline-string) ( start-index end-text -- end-index ) - lexer get line-text 2dup start + lexer get lexer-line-text 2dup start [ rot dupd >r >r swap subseq % r> r> length + ] [ rot tail % "\n" % 0 lexer get next-line swap (parse-multiline-string) From ac0aa6b3b20354042f1b7dd74e596768391d2a5d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 5 Feb 2008 22:49:36 -0600 Subject: [PATCH 49/62] do a better merge --- Makefile | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/Makefile b/Makefile index 06d0b28ccf..05a185f643 100755 --- a/Makefile +++ b/Makefile @@ -126,14 +126,10 @@ solaris-x86-64: winnt-x86-32: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 -<<<<<<< HEAD:Makefile -windows-nt-x86-64: +winnt-x86-64: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64 -windows-ce-arm: -======= wince-arm: ->>>>>>> 1eda70f1ad1f0d744ed846ce8c975a1cd4b28fb6:Makefile $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm macosx.app: factor From 3bbf622ff4795148fc10e5f9611029550a1c37db Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 5 Feb 2008 22:51:09 -0600 Subject: [PATCH 50/62] update factor.sh for new Makefile renaming --- misc/factor.sh | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/misc/factor.sh b/misc/factor.sh index d1ef738cd9..903038a964 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -99,9 +99,9 @@ find_os() { uname_s=`uname -s` check_ret uname case $uname_s in - CYGWIN_NT-5.2-WOW64) OS=windows-nt;; - *CYGWIN_NT*) OS=windows-nt;; - *CYGWIN*) OS=windows-nt;; + CYGWIN_NT-5.2-WOW64) OS=winnt;; + *CYGWIN_NT*) OS=winnt;; + *CYGWIN*) OS=winnt;; *darwin*) OS=macosx;; *Darwin*) OS=macosx;; *linux*) OS=linux;; @@ -139,7 +139,7 @@ find_word_size() { set_factor_binary() { case $OS in - windows-nt) FACTOR_BINARY=factor-nt;; + winnt) FACTOR_BINARY=factor-nt;; macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; *) FACTOR_BINARY=factor;; esac @@ -227,7 +227,7 @@ get_boot_image() { } maybe_download_dlls() { - if [[ $OS == windows-nt ]] ; then + if [[ $OS == winnt ]] ; then wget http://factorcode.org/dlls/freetype6.dll check_ret wget wget http://factorcode.org/dlls/zlib1.dll From 4439e394cca6be96a06d85a9532795bd052f8f1a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 5 Feb 2008 23:04:31 -0600 Subject: [PATCH 51/62] fix getcwd --- extra/io/unix/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index a70f7339d2..101114ffb2 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -6,7 +6,7 @@ alien ; IN: io.unix.files M: unix-io cwd - MAXPATHLEN dup getcwd + MAXPATHLEN dup swap getcwd [ alien>char-string ] [ (io-error) ] if* ; M: unix-io cd From 537d94566005c51b29fe358f79d2709b33c4b392 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 5 Feb 2008 23:14:10 -0600 Subject: [PATCH 52/62] fix getcwd --- extra/io/unix/files/files.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 101114ffb2..3bf0e3f897 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -6,8 +6,8 @@ alien ; IN: io.unix.files M: unix-io cwd - MAXPATHLEN dup swap getcwd - [ alien>char-string ] [ (io-error) ] if* ; + MAXPATHLEN dup swap + getcwd [ (io-error) ] unless* ; M: unix-io cd chdir io-error ; From 548e6dce4774507eb289968268438c255028c054 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 12:09:42 -0600 Subject: [PATCH 53/62] Fixing crossreferencing --- core/compiler/test/redefine.factor | 37 +++++++++++++++++++++++++++++ core/generic/generic-tests.factor | 37 +++++++++++++++++++++++++++++ core/generic/generic.factor | 7 +++++- core/words/words.factor | 29 ++++++++++------------ extra/help/handbook/handbook.factor | 2 ++ 5 files changed, 94 insertions(+), 18 deletions(-) diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 01dd27f8be..9bcdcdfcde 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -250,3 +250,40 @@ DEFER: defer-redefine-test-2 [ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test [ 2 1 ] [ defer-redefine-test-2 ] unit-test + +! Cross-referencing issue +: compiled-xref-a ; + +: compiled-xref-c ; inline + +GENERIC: compiled-xref-b ( a -- b ) + +TUPLE: c-1 ; + +M: c-1 compiled-xref-b compiled-xref-a compiled-xref-c ; + +TUPLE: c-2 ; + +M: c-2 compiled-xref-b drop 3 ; + +[ t ] [ + \ compiled-xref-a compiled-crossref get key? +] unit-test + +[ ] [ + [ + \ compiled-xref-a forget + ] with-compilation-unit +] unit-test + +[ f ] [ + \ compiled-xref-a compiled-crossref get key? +] unit-test + +[ ] [ + "IN: temporary : compiled-xref-c ; FORGET: { c-2 compiled-xref-b }" eval +] unit-test + +[ f ] [ + \ compiled-xref-a compiled-crossref get key? +] unit-test diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index f1e1ebd6d2..4de05aafd0 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -203,3 +203,40 @@ TUPLE: redefinition-test-tuple ; redefinition-test-generic , ] { } make all-equal? ] unit-test + +! Issues with forget +GENERIC: generic-forget-test-1 + +M: integer generic-forget-test-1 / ; + +[ t ] [ + \ / usage [ word? ] subset + [ word-name "generic-forget-test-1/integer" = ] contains? +] unit-test + +[ ] [ + [ \ generic-forget-test-1 forget ] with-compilation-unit +] unit-test + +[ f ] [ + \ / usage [ word? ] subset + [ word-name "generic-forget-test-1/integer" = ] contains? +] unit-test + +GENERIC: generic-forget-test-2 + +M: sequence generic-forget-test-2 = ; + +[ t ] [ + \ = usage [ word? ] subset + [ word-name "generic-forget-test-2/sequence" = ] contains? +] unit-test + +[ ] [ + [ { sequence generic-forget-test-2 } forget ] with-compilation-unit +] unit-test + +[ f ] [ + \ = usage [ word? ] subset + [ word-name "generic-forget-test-2/sequence" = ] contains? +] unit-test diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 453d72effb..53f47c09d5 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -102,7 +102,9 @@ M: method-spec definition first2 method dup [ method-def ] when ; : forget-method ( class generic -- ) - check-method [ delete-at ] with-methods ; + check-method + [ delete-at* ] with-methods + [ method-word forget ] [ drop ] if ; M: method-spec forget* first2 forget-method ; @@ -145,5 +147,8 @@ M: generic subwords swap "default-method" word-prop add [ method-word ] map ; +M: generic forget-word + dup subwords [ forget-word ] each (forget-word) ; + : xref-generics ( -- ) all-words [ subwords [ xref ] each ] each ; diff --git a/core/words/words.factor b/core/words/words.factor index 93b1185335..c2118598af 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -71,7 +71,9 @@ GENERIC# (quot-uses) 1 ( obj assoc -- ) M: object (quot-uses) 2drop ; -M: interned (quot-uses) dupd set-at ; +M: word (quot-uses) + >r dup "forgotten" word-prop + [ r> 2drop ] [ dup r> set-at ] if ; : seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ; @@ -194,24 +196,17 @@ M: word where "loc" word-prop ; M: word set-where swap "loc" set-word-prop ; -GENERIC: (forget-word) ( word -- ) +GENERIC: forget-word ( word -- ) -M: interned (forget-word) - dup word-name swap word-vocabulary vocab-words delete-at ; +: (forget-word) ( word -- ) + dup "forgotten" word-prop [ + dup delete-xref + dup delete-compiled-xref + dup word-name over word-vocabulary vocab-words delete-at + dup t "forgotten" set-word-prop + ] unless drop ; -M: word (forget-word) - drop ; - -: rename-word ( word newname newvocab -- ) - pick (forget-word) - pick set-word-vocabulary - over set-word-name - reveal ; - -: forget-word ( word -- ) - dup delete-xref - dup delete-compiled-xref - (forget-word) ; +M: word forget-word (forget-word) ; M: word forget* forget-word ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 81e4bea7b3..d6b4ec7ffe 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -32,6 +32,8 @@ $nl { { $snippet "with-" { $emphasis "foo" } } { "performs some kind of initialization and cleanup related to " { $snippet "foo" } ", usually in a new dynamic scope" } { $links with-scope with-stream } } { { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } } } +{ $heading "Stack effect conventions" } +"Stack effect conventions are documented in " { $link "effect-declaration" } "." { $heading "Glossary of terms" } "Common terminology and abbreviations used throughout Factor and its documentation:" { $table From 38b4f67b70d7cbe007fdb525dc8931edae8bd6b7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 12:44:13 -0600 Subject: [PATCH 54/62] Save bootstrap time in a global variable --- core/bootstrap/stage2.factor | 79 +++++++++++++++++++++++------------- 1 file changed, 51 insertions(+), 28 deletions(-) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 1a9bdd599a..9dd56c6524 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -8,25 +8,63 @@ definitions assocs compiler.errors compiler.units math.parser generic ; IN: bootstrap.stage2 +SYMBOL: bootstrap-time + +: default-image-name ( -- string ) + vm file-name windows? [ "." split1 drop ] when + ".image" append ; + +: do-crossref ( -- ) + "Cross-referencing..." print flush + H{ } clone crossref set-global + xref-words + xref-generics + xref-sources ; + +: load-components ( -- ) + "exclude" "include" + [ get-global " " split [ empty? not ] subset ] 2apply + seq-diff + [ "bootstrap." swap append require ] each ; + +: compile-remaining ( -- ) + "Compiling remaining words..." print flush + vocabs [ + words "compile" "compiler" lookup execute + ] each ; + +: count-words ( pred -- ) + all-words swap subset length number>string write ; + +: print-report ( time -- ) + 1000 /i + 60 /mod swap + "Bootstrap completed in " write number>string write + " minutes and " write number>string write " seconds." print + + [ compiled? ] count-words " compiled words" print + [ symbol? ] count-words " symbol words" print + [ ] count-words " words total" print + + "Bootstrapping is complete." print + "Now, you can run Factor:" print + vm write " -i=" write "output-image" get print flush ; + ! Wrap everything in a catch which starts a listener so ! you can see what went wrong, instead of dealing with a ! fep [ - vm file-name windows? [ "." split1 drop ] when - ".image" append "output-image" set-global + ! We time bootstrap + millis >r + + default-image-name "output-image" set-global "math help compiler tools ui ui.tools io" "include" set-global "" "exclude" set-global parse-command-line - "-no-crossref" cli-args member? [ - "Cross-referencing..." print flush - H{ } clone crossref set-global - xref-words - xref-generics - xref-sources - ] unless + "-no-crossref" cli-args member? [ do-crossref ] unless ! Set dll paths wince? [ "windows.ce" require ] when @@ -40,19 +78,12 @@ IN: bootstrap.stage2 ] if [ - "exclude" "include" - [ get-global " " split [ empty? not ] subset ] 2apply - seq-diff - [ "bootstrap." swap append require ] each + load-components run-bootstrap-init - "Compiling remaining words..." print flush - "bootstrap.compiler" vocab [ - vocabs [ - words "compile" "compiler" lookup execute - ] each + compile-remaining ] when ] with-compiler-errors :errors @@ -74,16 +105,8 @@ IN: bootstrap.stage2 ] [ print-error 1 exit ] recover ] set-boot-quot - : count-words ( pred -- ) - all-words swap subset length number>string write ; - - [ compiled? ] count-words " compiled words" print - [ symbol? ] count-words " symbol words" print - [ ] count-words " words total" print - - "Bootstrapping is complete." print - "Now, you can run Factor:" print - vm write " -i=" write "output-image" get print flush + millis r> - dup bootstrap-time set-global + print-report "output-image" get resource-path save-image-and-exit ] if From d9338b1cd26a519d00fee2bbab7cebdcf888ecb0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 12:47:15 -0600 Subject: [PATCH 55/62] Remove interned predicate class --- core/classes/classes-tests.factor | 4 +++- core/compiler/test/redefine.factor | 4 +--- core/source-files/source-files.factor | 2 +- core/tuples/tuples-tests.factor | 2 +- core/vocabs/vocabs-docs.factor | 2 +- core/words/words-docs.factor | 16 +--------------- core/words/words-tests.factor | 11 +---------- core/words/words.factor | 21 ++++++++++++--------- 8 files changed, 21 insertions(+), 41 deletions(-) mode change 100644 => 100755 core/vocabs/vocabs-docs.factor diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 854e6add5a..efff0db5d1 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -172,7 +172,9 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ; FORGET: forget-class-bug-1 FORGET: forget-class-bug-2 -[ t ] [ integer dll class-or interned? ] unit-test +[ f ] [ forget-class-bug-1 typemap get values [ memq? ] with contains? ] unit-test + +[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test DEFER: mixin-forget-test-g diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 9bcdcdfcde..5d07e764d6 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -92,8 +92,6 @@ DEFER: x-4 [ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test -[ t ] [ \ x-3 "compiled-uses" word-prop [ drop interned? ] assoc-all? ] unit-test - DEFER: g-test-1 DEFER: g-test-3 @@ -237,7 +235,7 @@ DEFER: flushable-test-2 : bx ax ; [ \ bx forget ] with-compilation-unit -[ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test +[ f ] [ \ bx \ ax compiled-usage contains? ] unit-test DEFER: defer-redefine-test-2 diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 64ae2e376e..7ddf6f02c0 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -38,7 +38,7 @@ uses definitions ; : (xref-source) ( source-file -- pathname uses ) dup source-file-path swap source-file-uses - [ interned? ] subset ; + [ crossref? ] subset ; : xref-source ( source-file -- ) (xref-source) crossref get add-vertex ; diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index edd2387645..627ee5562f 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -123,7 +123,7 @@ TUPLE: yo-momma ; [ ] [ \ yo-momma forget ] unit-test [ f ] [ \ yo-momma typemap get values memq? ] unit-test - [ f ] [ \ yo-momma interned? ] unit-test + [ f ] [ \ yo-momma crossref ] unit-test ] with-compilation-unit TUPLE: loc-recording ; diff --git a/core/vocabs/vocabs-docs.factor b/core/vocabs/vocabs-docs.factor old mode 100644 new mode 100755 index cb2cabb369..f16a33f0d5 --- a/core/vocabs/vocabs-docs.factor +++ b/core/vocabs/vocabs-docs.factor @@ -76,7 +76,7 @@ HELP: all-words HELP: forget-vocab { $values { "vocab" string } } -{ $description "Removes a vocabulary. All words in the vocabulary become uninterned." } +{ $description "Removes a vocabulary. All words in the vocabulary are forgotten." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } ; HELP: load-vocab-hook diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 24e81c70a6..62848e46b2 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -14,9 +14,7 @@ $nl { $subsection lookup } "Words can output their name and vocabulary:" { $subsection word-name } -{ $subsection word-vocabulary } -"Testing if a word object is part of a vocabulary:" -{ $subsection interned? } ; +{ $subsection word-vocabulary } ; ARTICLE: "uninterned-words" "Uninterned words" "A word that is not a member of any vocabulary is said to be " { $emphasis "uninterned" } "." @@ -369,18 +367,6 @@ HELP: delimiter? { $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." } { $notes "Outputs " { $link f } " if the object is not a word." } ; -HELP: interned -{ $class-description "The class of words defined in the " { $link dictionary } "." } -{ $examples - { $example "\\ + interned? ." "t" } - { $example "gensym interned? ." "f" } -} ; - -HELP: rename-word -{ $values { "word" word } { "newname" string } { "newvocab" string } } -{ $description "Changes the name and vocabulary of a word, and adds it to its new vocabulary." } -{ $side-effects "word" } ; - HELP: make-flushable { $values { "word" word } } { $description "Declares a word as " { $link POSTPONE: flushable } "." } diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 35a2421e71..92f5284c49 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -54,22 +54,14 @@ GENERIC: testing [ f ] [ \ testing generic? ] unit-test -[ f ] [ gensym interned? ] unit-test - : forgotten ; : another-forgotten ; -[ f ] [ \ forgotten interned? ] unit-test - FORGET: forgotten -[ f ] [ \ another-forgotten interned? ] unit-test - FORGET: another-forgotten : another-forgotten ; -[ t ] [ \ + interned? ] unit-test - ! I forgot remove-crossref calls! : fee ; : foe fee ; @@ -87,8 +79,7 @@ FORGET: foe ] unit-test [ t ] [ - \ * usage [ word? ] subset - [ dup interned? swap method-body? or ] all? + \ * usage [ word? ] subset [ crossref? ] all? ] unit-test DEFER: calls-a-gensym diff --git a/core/words/words.factor b/core/words/words.factor index c2118598af..f628d68bee 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: words USING: arrays definitions graphs assocs kernel kernel.private slots.private math namespaces sequences strings vectors sbufs quotations assocs hashtables sorting math.parser words.private -vocabs ; +vocabs combinators ; +IN: words : word ( -- word ) \ word get-global ; @@ -65,15 +65,20 @@ SYMBOL: bootstrapping? : bootstrap-word ( word -- target ) [ target-word ] [ ] if-bootstrapping ; -PREDICATE: word interned dup target-word eq? ; +: crossref? ( word -- ? ) + { + { [ dup "forgotten" word-prop ] [ f ] } + { [ dup "method" word-prop ] [ t ] } + { [ dup word-vocabulary ] [ t ] } + { [ t ] [ f ] } + } cond nip ; GENERIC# (quot-uses) 1 ( obj assoc -- ) M: object (quot-uses) 2drop ; M: word (quot-uses) - >r dup "forgotten" word-prop - [ r> 2drop ] [ dup r> set-at ] if ; + >r dup crossref? [ dup r> set-at ] [ r> 2drop ] if ; : seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ; @@ -94,6 +99,7 @@ SYMBOL: compiled-crossref compiled-crossref global [ H{ } assoc-like ] change-at : compiled-xref ( word dependencies -- ) + [ crossref? ] subset 2dup "compiled-uses" set-word-prop compiled-crossref get add-vertex* ; @@ -118,9 +124,6 @@ SYMBOL: changed-words [ no-compilation-unit ] unless* set-at ; -: crossref? ( word -- ? ) - dup word-vocabulary swap "method" word-prop or ; - : define ( word def -- ) [ ] like over unxref From 8a4db990297699eb69f1e5c105230fa75314dc54 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 13:15:15 -0600 Subject: [PATCH 56/62] Improved tools.test --- extra/tools/test/test.factor | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 2a26c8639e..aa994e91d2 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -3,7 +3,7 @@ USING: namespaces arrays prettyprint sequences kernel vectors quotations words parser assocs combinators continuations debugger io io.files vocabs tools.time -vocabs.loader source-files compiler.units ; +vocabs.loader source-files compiler.units inspector ; IN: tools.test SYMBOL: failures @@ -30,9 +30,17 @@ SYMBOL: this-test TUPLE: expected-error ; -: unit-test-fails ( quot -- ) - [ f ] append [ [ drop t ] recover ] curry - [ t ] swap unit-test ; +M: expected-error summary + drop + "The unit test expected the quotation to throw an error" ; + +: must-fail-with ( quot test -- ) + >r [ expected-error construct-empty throw ] compose r> + [ recover ] 2curry + [ ] swap unit-test ; + +: must-fail ( quot -- ) + [ drop t ] must-fail-with ; : run-test ( path -- failures ) [ "temporary" forget-vocab ] with-compilation-unit From be2c8b13d742c843ed5cc1d1fe7019808d87d933 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 13:47:19 -0600 Subject: [PATCH 57/62] Rename unit-test-fails to must-fail and add must-fail-with to replace [ t ] [ [ ... ] catch ... ] unit-test idiom --- core/alien/alien-tests.factor | 6 +- core/alien/c-types/c-types-tests.factor | 2 +- core/arrays/arrays-tests.factor | 12 +-- core/bit-arrays/bit-arrays-tests.factor | 2 +- core/byte-arrays/byte-arrays-tests.factor | 2 +- core/classes/classes-tests.factor | 6 +- core/combinators/combinators-tests.factor | 2 +- core/compiler/test/alien.factor | 20 ++--- core/compiler/test/intrinsics.factor | 4 +- core/compiler/test/optimizer.factor | 4 +- core/compiler/test/redefine.factor | 2 +- core/compiler/test/simple.factor | 4 +- core/compiler/test/stack-trace.factor | 8 +- core/continuations/continuations-docs.factor | 12 +-- core/continuations/continuations-tests.factor | 42 +++++----- core/continuations/continuations.factor | 10 +-- core/float-arrays/float-arrays-tests.factor | 2 +- core/generic/generic-tests.factor | 8 +- core/growable/growable-tests.factor | 8 +- core/hashtables/hashtables-tests.factor | 6 +- core/heaps/heaps-tests.factor | 4 +- core/inference/inference-tests.factor | 72 +++++++---------- .../transforms/transforms-tests.factor | 2 +- core/io/streams/duplex/duplex-tests.factor | 4 +- core/kernel/kernel-tests.factor | 46 +++++------ core/listener/listener-tests.factor | 4 +- core/math/integers/integers-tests.factor | 4 +- core/math/parser/parser-tests.factor | 6 +- core/memory/memory-tests.factor | 2 +- core/parser/parser-tests.factor | 78 ++++++++----------- core/quotations/quotations-tests.factor | 2 +- core/sequences/sequences-tests.factor | 20 ++--- core/splitting/splitting-tests.factor | 2 +- core/strings/strings-tests.factor | 11 ++- core/threads/threads-tests.factor | 2 +- core/tuples/tuples-tests.factor | 18 ++--- core/vectors/vectors-tests.factor | 20 ++--- core/vocabs/loader/loader-tests.factor | 14 +--- core/words/words-tests.factor | 8 +- extra/bitfields/bitfields-tests.factor | 12 +-- extra/bootstrap/io/io.factor | 2 - extra/calendar/calendar-tests.factor | 16 ++-- extra/circular/circular-tests.factor | 4 +- extra/combinators/lib/lib-tests.factor | 15 ++-- extra/concurrency/concurrency-docs.factor | 2 +- extra/concurrency/concurrency-tests.factor | 15 ++-- extra/concurrency/concurrency.factor | 2 +- extra/coroutines/coroutines-tests.factor | 2 +- extra/crypto/xor/xor-tests.factor | 8 +- extra/db/postgresql/postgresql-tests.factor | 4 +- extra/db/sqlite/sqlite-tests.factor | 4 +- extra/destructors/destructors-tests.factor | 4 +- extra/help/crossref/crossref-tests.factor | 2 +- extra/inverse/inverse-tests.factor | 8 +- extra/io/buffers/buffers-tests.factor | 2 +- extra/io/mmap/mmap-tests.factor | 4 +- extra/io/unix/launcher/launcher-tests.factor | 8 +- extra/io/unix/linux/linux.factor | 6 +- extra/io/unix/unix-tests.factor | 20 ++--- extra/io/windows/nt/nt.factor | 3 + extra/irc/irc.factor | 2 +- extra/math/complex/complex-tests.factor | 4 +- extra/math/functions/functions-tests.factor | 2 +- extra/memoize/memoize-tests.factor | 2 +- .../multi-methods/multi-methods-tests.factor | 2 +- .../parser-combinators-tests.factor | 2 +- extra/regexp/regexp-tests.factor | 2 +- extra/roman/roman-tests.factor | 6 +- extra/sequences/lib/lib-tests.factor | 2 +- extra/tetris/board/board-tests.factor | 2 +- .../interpreter/interpreter-tests.factor | 2 +- extra/tools/test/inference/inference.factor | 7 +- extra/tools/test/test.factor | 3 + extra/ui/tools/listener/listener-tests.factor | 2 +- extra/xml/test/errors.factor | 2 +- extra/xml/test/test.factor | 2 +- 76 files changed, 299 insertions(+), 369 deletions(-) diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index d5133753c1..74c94c8edf 100755 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -14,7 +14,7 @@ prettyprint ; ! Testing the various bignum accessor 10 "dump" set -[ "dump" get alien-address ] unit-test-fails +[ "dump" get alien-address ] must-fail [ 123 ] [ 123 "dump" get 0 set-alien-signed-1 @@ -61,9 +61,9 @@ cell 8 = [ [ ] [ 0 F{ 1 2 3 } drop ] unit-test [ ] [ 0 ?{ t f t } drop ] unit-test -[ 0 B{ 1 2 3 } alien-address ] unit-test-fails +[ 0 B{ 1 2 3 } alien-address ] must-fail -[ 1 1 ] unit-test-fails +[ 1 1 ] must-fail [ f ] [ 0 B{ 1 2 3 } pinned-c-ptr? ] unit-test diff --git a/core/alien/c-types/c-types-tests.factor b/core/alien/c-types/c-types-tests.factor index 3148b85782..719068e031 100755 --- a/core/alien/c-types/c-types-tests.factor +++ b/core/alien/c-types/c-types-tests.factor @@ -71,4 +71,4 @@ TYPEDEF: uchar* MyLPBYTE [ 0 B{ 1 2 3 4 } -] unit-test-fails +] must-fail diff --git a/core/arrays/arrays-tests.factor b/core/arrays/arrays-tests.factor index 3ff81fda72..e07f192197 100755 --- a/core/arrays/arrays-tests.factor +++ b/core/arrays/arrays-tests.factor @@ -2,10 +2,10 @@ USING: arrays kernel sequences sequences.private growable tools.test vectors layouts system math vectors.private ; IN: temporary -[ -2 { "a" "b" "c" } nth ] unit-test-fails -[ 10 { "a" "b" "c" } nth ] unit-test-fails -[ "hi" -2 { "a" "b" "c" } set-nth ] unit-test-fails -[ "hi" 10 { "a" "b" "c" } set-nth ] unit-test-fails +[ -2 { "a" "b" "c" } nth ] must-fail +[ 10 { "a" "b" "c" } nth ] must-fail +[ "hi" -2 { "a" "b" "c" } set-nth ] must-fail +[ "hi" 10 { "a" "b" "c" } set-nth ] must-fail [ f ] [ { "a" "b" "c" } dup clone eq? ] unit-test [ "hi" ] [ "hi" 1 { "a" "b" "c" } clone [ set-nth ] keep second ] unit-test [ V{ "a" "b" "c" } ] [ { "a" "b" "c" } >vector ] unit-test @@ -17,5 +17,5 @@ IN: temporary [ { "a" "b" "c" "d" "e" } ] [ { "a" } { "b" "c" } { "d" "e" } 3append ] unit-test -[ -1 f ] unit-test-fails -[ cell-bits cell log2 - 2^ f ] unit-test-fails +[ -1 f ] must-fail +[ cell-bits cell log2 - 2^ f ] must-fail diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor index f605eba24c..5f89b90608 100755 --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -51,4 +51,4 @@ IN: temporary [ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test -[ -10 ?{ } resize-bit-array ] unit-test-fails +[ -10 ?{ } resize-bit-array ] must-fail diff --git a/core/byte-arrays/byte-arrays-tests.factor b/core/byte-arrays/byte-arrays-tests.factor index b39551eb86..b5b01c201b 100755 --- a/core/byte-arrays/byte-arrays-tests.factor +++ b/core/byte-arrays/byte-arrays-tests.factor @@ -5,4 +5,4 @@ USING: tools.test byte-arrays ; [ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test -[ -10 B{ } resize-byte-array ] unit-test-fails +[ -10 B{ } resize-byte-array ] must-fail diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index efff0db5d1..d78436bd5f 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -91,7 +91,7 @@ M: union-1 generic-update-test drop "union-1" ; [ f ] [ union-1 union-class? ] unit-test [ t ] [ union-1 predicate-class? ] unit-test [ "union-1" ] [ 8 generic-update-test ] unit-test -[ -7 generic-update-test ] unit-test-fails +[ -7 generic-update-test ] must-fail ! Test mixins MIXIN: sequence-mixin @@ -193,7 +193,7 @@ DEFER: mixin-forget-test-g ] unit-test [ { } ] [ { } mixin-forget-test-g ] unit-test -[ H{ } mixin-forget-test-g ] unit-test-fails +[ H{ } mixin-forget-test-g ] must-fail [ ] [ { @@ -207,7 +207,7 @@ DEFER: mixin-forget-test-g parse-stream drop ] unit-test -[ { } mixin-forget-test-g ] unit-test-fails +[ { } mixin-forget-test-g ] must-fail [ H{ } ] [ H{ } mixin-forget-test-g ] unit-test ! Method flattening interfered with mixin update diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 208f8c0c84..3cefda7f71 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -38,7 +38,7 @@ namespaces combinators words ; ! Interpreted [ "two" ] [ 2 \ case-test-1 word-def call ] unit-test -[ "x" case-test-1 ] unit-test-fails +[ "x" case-test-1 ] must-fail : case-test-2 { diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor index 9416fd1415..dbdbbfc9fa 100755 --- a/core/compiler/test/alien.factor +++ b/core/compiler/test/alien.factor @@ -13,7 +13,7 @@ FUNCTION: int ffi_test_1 ; FUNCTION: int ffi_test_2 int x int y ; [ 5 ] [ 2 3 ffi_test_2 ] unit-test -[ "hi" 3 ffi_test_2 ] unit-test-fails +[ "hi" 3 ffi_test_2 ] must-fail FUNCTION: int ffi_test_3 int x int y int z int t ; [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test @@ -26,8 +26,8 @@ FUNCTION: double ffi_test_5 ; FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ; [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test -[ "a" 2 3 4 5 6 7 ffi_test_9 ] unit-test-fails -[ 1 2 3 4 5 6 "a" ffi_test_9 ] unit-test-fails +[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail +[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail C-STRUCT: foo { "int" "x" } @@ -53,7 +53,7 @@ FUNCTION: char* ffi_test_15 char* x char* y ; [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test -[ 1 2 ffi_test_15 ] unit-test-fails +[ 1 2 ffi_test_15 ] must-fail C-STRUCT: bar { "long" "x" } @@ -75,7 +75,7 @@ FUNCTION: tiny ffi_test_17 int x ; [ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test -[ t ] [ [ [ alien-indirect ] infer ] catch inference-error? ] unit-test +[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with : indirect-test-1 "int" { } "cdecl" alien-indirect ; @@ -84,7 +84,7 @@ FUNCTION: tiny ffi_test_17 int x ; [ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test -[ -1 indirect-test-1 ] unit-test-fails +[ -1 indirect-test-1 ] must-fail : indirect-test-2 "int" { "int" "int" } "cdecl" alien-indirect data-gc ; @@ -120,7 +120,7 @@ unit-test FUNCTION: double ffi_test_6 float x float y ; [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test -[ "a" "b" ffi_test_6 ] unit-test-fails +[ "a" "b" ffi_test_6 ] must-fail FUNCTION: double ffi_test_7 double x double y ; [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test @@ -157,7 +157,7 @@ FUNCTION: long ffi_test_22 long x longlong y longlong z ; [ 987655432 ] [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test -[ 1111 f 123456789 ffi_test_22 ] unit-test-fails +[ 1111 f 123456789 ffi_test_22 ] must-fail C-STRUCT: rect { "float" "x" } @@ -177,7 +177,7 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 7 8 9 ffi_test_12 ] unit-test -[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] unit-test-fails +[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; @@ -292,7 +292,7 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; [ ] [ callback-1 callback_test_1 ] unit-test -: callback-2 "void" { } "cdecl" [ [ 5 throw ] catch drop ] alien-callback ; +: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; [ ] [ callback-2 callback_test_1 ] unit-test diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor index 1d0ad141c2..679938b7f3 100755 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -422,11 +422,11 @@ cell 8 = [ [ B{ 0 0 0 0 } [ { byte-array } declare ] compile-call -] unit-test-fails +] must-fail [ B{ 0 0 0 0 } [ { c-ptr } declare ] compile-call -] unit-test-fails +] must-fail [ 4 5 diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor index b59c0d5f33..091648cbbc 100755 --- a/core/compiler/test/optimizer.factor +++ b/core/compiler/test/optimizer.factor @@ -136,7 +136,7 @@ TUPLE: pred-test ; GENERIC: void-generic ( obj -- * ) : breakage "hi" void-generic ; [ t ] [ \ breakage compiled? ] unit-test -[ breakage ] unit-test-fails +[ breakage ] must-fail ! regression : test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline @@ -247,7 +247,7 @@ M: slice foozul ; GENERIC: detect-number ( obj -- obj ) M: number detect-number ; -[ 10 f [ 0 + detect-number ] compile-call ] unit-test-fails +[ 10 f [ 0 + detect-number ] compile-call ] must-fail ! Regression [ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 5d07e764d6..e9927f4964 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -243,7 +243,7 @@ DEFER: defer-redefine-test-2 [ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test -[ defer-redefine-test-2 ] unit-test-fails +[ defer-redefine-test-2 ] must-fail [ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test diff --git a/core/compiler/test/simple.factor b/core/compiler/test/simple.factor index 9f831bb1f8..6f5cb33c1a 100755 --- a/core/compiler/test/simple.factor +++ b/core/compiler/test/simple.factor @@ -57,8 +57,8 @@ IN: temporary ! Make sure error reporting works -[ [ dup ] compile-call ] unit-test-fails -[ [ drop ] compile-call ] unit-test-fails +[ [ dup ] compile-call ] must-fail +[ [ drop ] compile-call ] must-fail ! Regression diff --git a/core/compiler/test/stack-trace.factor b/core/compiler/test/stack-trace.factor index 59ee3c3d88..71c95b1b61 100755 --- a/core/compiler/test/stack-trace.factor +++ b/core/compiler/test/stack-trace.factor @@ -10,7 +10,7 @@ words splitting ; : foo 3 throw 7 ; : bar foo 4 ; : baz bar 5 ; -[ 3 ] [ [ baz ] catch ] unit-test +[ baz ] [ 3 = ] must-fail-with [ t ] [ symbolic-stack-trace [ word? ] subset @@ -22,11 +22,11 @@ words splitting ; : stack-trace-contains? symbolic-stack-trace memq? ; [ t ] [ - [ { 1 "hi" } bleh ] catch drop \ + stack-trace-contains? + [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains? ] unit-test [ t f ] [ - [ { "hi" } bleh ] catch drop + [ { "hi" } bleh ] ignore-errors \ + stack-trace-contains? \ > stack-trace-contains? ] unit-test @@ -34,6 +34,6 @@ words splitting ; : quux [ t [ "hi" throw ] when ] times ; [ t ] [ - [ 10 quux ] catch drop + [ 10 quux ] ignore-errors \ (each-integer) stack-trace-contains? ] unit-test diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 51e461c715..2977d02c6f 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -23,10 +23,9 @@ $nl "Two words raise an error in the innermost error handler for the current dynamic extent:" { $subsection throw } { $subsection rethrow } -"A set of words establish an error handler:" +"Two words for establishing an error handler:" { $subsection cleanup } { $subsection recover } -{ $subsection catch } "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." { $subsection "errors-restartable" } { $subsection "errors-post-mortem" } ; @@ -147,12 +146,7 @@ HELP: throw { $values { "error" object } } { $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ; -HELP: catch -{ $values { "try" quotation } { "error/f" object } } -{ $description "Calls the " { $snippet "try" } " quotation. If an error is thrown in the dynamic extent of the quotation, restores the data stack and pushes the error. If the quotation returns successfully, outputs " { $link f } " without restoring the data stack." } -{ $notes "This word cannot differentiate between the case of " { $link f } " being thrown, and no error being thrown. You should never throw " { $link f } ", and you should also use other error handling combinators where possible." } ; - -{ catch cleanup recover } related-words +{ cleanup recover } related-words HELP: cleanup { $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } } @@ -166,7 +160,7 @@ HELP: rethrow { $values { "error" object } } { $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." } { $notes - "This word is intended to be used in conjunction with " { $link recover } " or " { $link catch } " to implement error handlers which perform an action and pass the error to the next outermost error handler." + "This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler." } { $examples "The " { $link with-parser } " catches errors, annotates them with file name and line number information, and rethrows them:" diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 360f4750c9..b7d580afe5 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -25,13 +25,11 @@ IN: temporary [ t ] [ 10 callcc1-test 10 reverse >vector = ] unit-test [ t ] [ callcc-namespace-test ] unit-test -[ f ] [ [ ] catch ] unit-test - -[ 5 ] [ [ 5 throw ] catch ] unit-test +[ 5 throw ] [ 5 = ] must-fail-with [ t ] [ - [ "Hello" throw ] catch drop - global [ error get ] bind + [ "Hello" throw ] ignore-errors + error get-global "Hello" = ] unit-test @@ -41,13 +39,13 @@ IN: temporary "!!! The following error is part of the test" print -[ [ "2 car" ] eval ] catch print-error +[ ] [ [ [ "2 car" ] eval ] [ print-error ] recover ] unit-test -[ f throw ] unit-test-fails +[ f throw ] must-fail ! Weird PowerPC bug. [ ] [ - [ "4" throw ] catch drop + [ "4" throw ] ignore-errors data-gc data-gc ] unit-test @@ -56,10 +54,10 @@ IN: temporary [ f ] [ { "A" "B" } kernel-error? ] unit-test ! ! See how well callstack overflow is handled -! [ clear drop ] unit-test-fails +! [ clear drop ] must-fail ! ! : callstack-overflow callstack-overflow f ; -! [ callstack-overflow ] unit-test-fails +! [ callstack-overflow ] must-fail : don't-compile-me { } [ ] each ; @@ -84,24 +82,20 @@ SYMBOL: error-counter [ 1 ] [ always-counter get ] unit-test [ 0 ] [ error-counter get ] unit-test - [ "a" ] [ - [ - [ "a" throw ] - [ always-counter inc ] - [ error-counter inc ] cleanup - ] catch - ] unit-test + [ + [ "a" throw ] + [ always-counter inc ] + [ error-counter inc ] cleanup + ] [ "a" = ] must-fail-with [ 2 ] [ always-counter get ] unit-test [ 1 ] [ error-counter get ] unit-test - [ "a" ] [ - [ - [ ] - [ always-counter inc "a" throw ] - [ error-counter inc ] cleanup - ] catch - ] unit-test + [ + [ ] + [ always-counter inc "a" throw ] + [ error-counter inc ] cleanup + ] [ "a" = ] must-fail-with [ 3 ] [ always-counter get ] unit-test [ 1 ] [ error-counter get ] unit-test diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 6e4ce16bea..b6ca056691 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays vectors kernel kernel.private sequences namespaces math splitting sorting quotations assocs ; @@ -17,9 +17,6 @@ SYMBOL: restarts : c> ( -- continuation ) catchstack* pop ; -: (catch) ( quot -- newquot ) - [ swap >c call c> drop ] curry ; inline - : dummy ( -- obj ) #! Optimizing compiler assumes stack won't be messed with #! in-transit. To ensure that a value is actually reified @@ -120,11 +117,8 @@ PRIVATE> catchstack* empty? [ die ] when dup save-error c> continue-with ; -: catch ( try -- error/f ) - (catch) [ f ] compose callcc1 ; inline - : recover ( try recovery -- ) - >r (catch) r> ifcc ; inline + >r [ swap >c call c> drop ] curry r> ifcc ; inline : cleanup ( try cleanup-always cleanup-error -- ) over >r compose [ dip rethrow ] curry diff --git a/core/float-arrays/float-arrays-tests.factor b/core/float-arrays/float-arrays-tests.factor index afadaac0db..0e0ab3feb6 100755 --- a/core/float-arrays/float-arrays-tests.factor +++ b/core/float-arrays/float-arrays-tests.factor @@ -7,4 +7,4 @@ USING: float-arrays tools.test ; [ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize-float-array ] unit-test -[ -10 F{ } resize-float-array ] unit-test-fails +[ -10 F{ } resize-float-array ] must-fail diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 4de05aafd0..e4d4160605 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -16,7 +16,7 @@ M: word class-of drop "word" ; [ "fixnum" ] [ 5 class-of ] unit-test [ "word" ] [ \ class-of class-of ] unit-test -[ 3.4 class-of ] unit-test-fails +[ 3.4 class-of ] must-fail [ "Hello world" ] [ 4 foobar foobar ] unit-test [ "Goodbye cruel world" ] [ 4 foobar ] unit-test @@ -90,7 +90,7 @@ M: number union-containment drop 2 ; "IN: temporary GENERIC: unhappy ( x -- x )" eval [ "IN: temporary M: dictionary unhappy ;" eval -] unit-test-fails +] must-fail [ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test GENERIC# complex-combination 1 ( a b -- c ) @@ -155,9 +155,7 @@ M: string my-hook "a string" ; [ "an integer" ] [ 3 my-var set my-hook ] unit-test [ "a string" ] [ my-hook my-var set my-hook ] unit-test -[ T{ no-method f 1.0 my-hook } ] [ - 1.0 my-var set [ my-hook ] catch -] unit-test +[ 1.0 my-var set my-hook ] [ [ T{ no-method f 1.0 my-hook } = ] must-fail-with GENERIC: tag-and-f ( x -- x x ) diff --git a/core/growable/growable-tests.factor b/core/growable/growable-tests.factor index 39d8721726..a220ccc45e 100755 --- a/core/growable/growable-tests.factor +++ b/core/growable/growable-tests.factor @@ -9,16 +9,16 @@ IN: temporary ! overflow bugs [ "hi" most-positive-fixnum 2 * 2 + V{ } clone set-nth ] -unit-test-fails +must-fail [ most-positive-fixnum 2 * 2 + { 1 } clone nth ] -unit-test-fails +must-fail [ most-positive-fixnum 2 * 2 + V{ } clone lengthen ] -unit-test-fails +must-fail [ most-positive-fixnum 2 * 2 + V{ } clone set-length ] -unit-test-fails +must-fail [ ] [ 10 V{ } [ set-length ] keep diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index 40d079402c..acb05be720 100755 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -127,9 +127,9 @@ H{ } "x" set ! Another crash discovered by erg [ ] [ H{ } clone - [ 1 swap set-at ] catch drop - [ 2 swap set-at ] catch drop - [ 3 swap set-at ] catch drop + [ 1 swap set-at ] ignore-errors + [ 2 swap set-at ] ignore-errors + [ 3 swap set-at ] ignore-errors drop ] unit-test diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index de661fad92..92b06b866c 100644 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -5,8 +5,8 @@ USING: arrays kernel math namespaces tools.test heaps heaps.private ; IN: temporary -[ heap-pop ] unit-test-fails -[ heap-pop ] unit-test-fails +[ heap-pop ] must-fail +[ heap-pop ] must-fail [ t ] [ heap-empty? ] unit-test [ f ] [ 1 t pick heap-push heap-empty? ] unit-test diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 3e3858d45d..1738a71b7e 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -12,14 +12,14 @@ IN: temporary { 1 2 } [ dup ] unit-test-effect { 1 2 } [ [ dup ] call ] unit-test-effect -[ [ call ] infer ] unit-test-fails +[ [ call ] infer ] must-fail { 2 4 } [ 2dup ] unit-test-effect { 1 0 } [ [ ] [ ] if ] unit-test-effect -[ [ if ] infer ] unit-test-fails -[ [ [ ] if ] infer ] unit-test-fails -[ [ [ 2 ] [ ] if ] infer ] unit-test-fails +[ [ if ] infer ] must-fail +[ [ [ ] if ] infer ] must-fail +[ [ [ 2 ] [ ] if ] infer ] must-fail { 4 3 } [ [ rot ] [ -rot ] if ] unit-test-effect { 4 3 } [ @@ -42,7 +42,7 @@ IN: temporary [ [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer -] unit-test-fails +] must-fail ! Test inference of termination of control flow : termination-test-1 @@ -54,10 +54,10 @@ IN: temporary : infinite-loop infinite-loop ; -[ [ infinite-loop ] infer ] unit-test-fails +[ [ infinite-loop ] infer ] must-fail : no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ; -[ [ no-base-case-1 ] infer ] unit-test-fails +[ [ no-base-case-1 ] infer ] must-fail : simple-recursion-1 ( obj -- obj ) dup [ simple-recursion-1 ] [ ] if ; @@ -72,7 +72,7 @@ IN: temporary : bad-recursion-2 ( obj -- obj ) dup [ dup first swap second bad-recursion-2 ] [ ] if ; -[ [ bad-recursion-2 ] infer ] unit-test-fails +[ [ bad-recursion-2 ] infer ] must-fail : funny-recursion ( obj -- obj ) dup [ funny-recursion 1 ] [ 2 ] if drop ; @@ -192,7 +192,7 @@ DEFER: blah4 [ swap slip ] keep swap bad-combinator ] if ; inline -[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails +[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail ! Regression : bad-input# @@ -207,13 +207,13 @@ DEFER: blah4 DEFER: do-crap : more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ; : do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ; -[ [ do-crap ] infer ] unit-test-fails +[ [ do-crap ] infer ] must-fail ! This one does not DEFER: do-crap* : more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ; : do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ; -[ [ do-crap* ] infer ] unit-test-fails +[ [ do-crap* ] infer ] must-fail ! Regression : too-deep ( a b -- c ) @@ -226,7 +226,7 @@ M: fixnum xyz 2array ; M: float xyz [ 3 ] 2apply swapd >r 2array swap r> 2array swap ; -[ t ] [ [ [ xyz ] infer ] catch inference-error? ] unit-test +[ [ xyz ] infer ] [ inference-error? ] must-fail-with ! Doug Coleman discovered this one while working on the ! calendar library @@ -277,78 +277,66 @@ DEFER: #1 : #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ; : #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ; -[ \ #4 word-def infer ] unit-test-fails -[ [ #1 ] infer ] unit-test-fails +[ \ #4 word-def infer ] must-fail +[ [ #1 ] infer ] must-fail ! Similar DEFER: bar : foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ; : bar ( a b -- ) [ 2 2 + ] t foo drop call drop ; -[ [ foo ] infer ] unit-test-fails +[ [ foo ] infer ] must-fail -[ 1234 infer ] unit-test-fails +[ 1234 infer ] must-fail ! This used to hang -[ t ] [ - [ [ [ dup call ] dup call ] infer ] catch - inference-error? -] unit-test +[ [ [ dup call ] dup call ] infer ] +[ inference-error? ] must-fail-with : m dup call ; inline -[ t ] [ - [ [ [ m ] m ] infer ] catch inference-error? -] unit-test +[ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with : m' dup curry call ; inline -[ t ] [ - [ [ [ m' ] m' ] infer ] catch inference-error? -] unit-test +[ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with : m'' [ dup curry ] ; inline : m''' m'' call call ; inline -[ t ] [ - [ [ [ m''' ] m''' ] infer ] catch inference-error? -] unit-test +[ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with : m-if t over if ; inline -[ t ] [ - [ [ [ m-if ] m-if ] infer ] catch inference-error? -] unit-test +[ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with ! This doesn't hang but it's also an example of the ! undedicable case -[ t ] [ - [ [ [ [ drop 3 ] swap call ] dup call ] infer ] catch - inference-error? -] unit-test +[ [ [ [ drop 3 ] swap call ] dup call ] infer ] +[ inference-error? ] must-fail-with ! This form should not have a stack effect : bad-recursion-1 ( a -- b ) dup [ drop bad-recursion-1 5 ] [ ] if ; -[ [ bad-recursion-1 ] infer ] unit-test-fails +[ [ bad-recursion-1 ] infer ] must-fail : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; -[ [ bad-bin ] infer ] unit-test-fails +[ [ bad-bin ] infer ] must-fail -[ t ] [ [ [ r> ] infer ] catch inference-error? ] unit-test +[ [ [ r> ] infer ] [ inference-error? ] must-fail-with ! Regression -[ t ] [ [ [ get-slots ] infer ] catch inference-error? ] unit-test +[ [ [ get-slots ] infer ] [ inference-error? ] must-fail-with ! Test some curry stuff { 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect { 2 1 } [ [ ] curry 4 [ ] curry if ] unit-test-effect -[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] unit-test-fails +[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail ! Test number protocol \ bitor must-infer @@ -459,7 +447,7 @@ DEFER: bar : fooxxx ( a b -- c ) over [ foo ] when ; inline : barxxx fooxxx ; -[ [ barxxx ] infer ] unit-test-fails +[ [ barxxx ] infer ] must-fail ! A typo { 1 0 } [ { [ ] } dispatch ] unit-test-effect diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index 152da8c757..f58e557b10 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -31,4 +31,4 @@ TUPLE: a-tuple x y z ; : set-slots-test-2 { set-a-tuple-x set-a-tuple-x } set-slots ; -[ [ set-slots-test-2 ] infer ] unit-test-fails +[ [ set-slots-test-2 ] infer ] must-fail diff --git a/core/io/streams/duplex/duplex-tests.factor b/core/io/streams/duplex/duplex-tests.factor index 962a46413f..44542e05ce 100755 --- a/core/io/streams/duplex/duplex-tests.factor +++ b/core/io/streams/duplex/duplex-tests.factor @@ -28,13 +28,13 @@ M: unclosable-stream dispose [ t ] [ [ - [ dup dispose ] catch 2drop + [ dup dispose ] [ 2drop ] recover ] keep closing-stream-closed? ] unit-test [ t ] [ [ - [ dup dispose ] catch 2drop + [ dup dispose ] [ 2drop ] recover ] keep closing-stream-closed? ] unit-test diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index c294c23738..e37b208ef0 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -7,25 +7,22 @@ IN: temporary [ t ] [ [ \ = \ = ] all-equal? ] unit-test ! Don't leak extra roots if error is thrown -[ ] [ 10000 [ [ 3 throw ] catch drop ] times ] unit-test +[ ] [ 10000 [ [ 3 throw ] ignore-errors ] times ] unit-test -[ ] [ 10000 [ [ -1 f ] catch drop ] times ] unit-test +[ ] [ 10000 [ [ -1 f ] ignore-errors ] times ] unit-test ! Make sure we report the correct error on stack underflow -[ { "kernel-error" 11 f f } ] -[ [ clear drop ] catch ] unit-test +[ clear drop ] [ { "kernel-error" 11 f f } = ] must-fail-with [ ] [ :c ] unit-test -[ { "kernel-error" 13 f f } ] -[ [ { } set-retainstack r> ] catch ] unit-test +[ { } set-retainstack r> ] [ { "kernel-error" 13 f f } = ] must-fail-with [ ] [ :c ] unit-test : overflow-d 3 overflow-d ; -[ { "kernel-error" 12 f f } ] -[ [ overflow-d ] catch ] unit-test +[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ :c ] unit-test @@ -33,24 +30,17 @@ IN: temporary : overflow-d-alt (overflow-d-alt) overflow-d-alt ; -[ { "kernel-error" 12 f f } ] -[ [ overflow-d-alt ] catch ] unit-test +[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ [ :c ] string-out drop ] unit-test : overflow-r 3 >r overflow-r ; -[ { "kernel-error" 14 f f } ] -[ [ overflow-r ] catch ] unit-test +[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with [ ] [ :c ] unit-test -! : overflow-c overflow-c 3 ; -! -! [ { "kernel-error" 16 f f } ] -! [ [ overflow-c ] catch ] unit-test - -[ -7 ] unit-test-fails +[ -7 ] must-fail [ 2 3 4 1 ] [ 1 2 3 4 roll ] unit-test [ 1 2 3 4 ] [ 2 3 4 1 -roll ] unit-test @@ -61,27 +51,27 @@ IN: temporary [ 4 ] [ 4 6 or ] unit-test [ 6 ] [ f 6 or ] unit-test -[ slip ] unit-test-fails +[ slip ] must-fail [ ] [ :c ] unit-test -[ 1 slip ] unit-test-fails +[ 1 slip ] must-fail [ ] [ :c ] unit-test -[ 1 2 slip ] unit-test-fails +[ 1 2 slip ] must-fail [ ] [ :c ] unit-test -[ 1 2 3 slip ] unit-test-fails +[ 1 2 3 slip ] must-fail [ ] [ :c ] unit-test [ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test -[ [ ] keep ] unit-test-fails +[ [ ] keep ] must-fail [ 6 ] [ 2 [ sq ] keep + ] unit-test -[ [ ] 2keep ] unit-test-fails -[ 1 [ ] 2keep ] unit-test-fails +[ [ ] 2keep ] must-fail +[ 1 [ ] 2keep ] must-fail [ 3 1 2 ] [ 1 2 [ 2drop 3 ] 2keep ] unit-test [ 0 ] [ f [ sq ] [ 0 ] if* ] unit-test @@ -100,13 +90,13 @@ IN: temporary [ ] [ callstack set-callstack ] unit-test -[ 3drop datastack ] unit-test-fails +[ 3drop datastack ] must-fail [ ] [ :c ] unit-test ! Doesn't compile; important : foo 5 + 0 [ ] each ; -[ drop foo ] unit-test-fails +[ drop foo ] must-fail [ ] [ :c ] unit-test ! Regression @@ -117,4 +107,4 @@ IN: temporary : loop ( obj obj -- ) H{ } values swap >r dup length swap r> 0 -roll (loop) ; -[ loop ] unit-test-fails +[ loop ] must-fail diff --git a/core/listener/listener-tests.factor b/core/listener/listener-tests.factor index 626c2b3e06..4570b1162a 100755 --- a/core/listener/listener-tests.factor +++ b/core/listener/listener-tests.factor @@ -22,7 +22,7 @@ IN: temporary [ "\\ + 1 2 3 4" parse-interactive "cont" get continue-with - ] catch + ] ignore-errors "USE: debugger :1" eval ] callcc1 ] unit-test @@ -36,7 +36,7 @@ IN: temporary [ "USE: vocabs.loader.test.c" parse-interactive -] unit-test-fails +] must-fail [ ] [ [ diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index 680119a56e..194edb8f7e 100755 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -121,8 +121,8 @@ unit-test ! We don't care if this fails or returns 0 (its CPU-specific) ! as long as it doesn't crash -[ ] [ [ 0 0 /i ] catch clear ] unit-test -[ ] [ [ 100000000000000000 0 /i ] catch clear ] unit-test +[ ] [ [ 0 0 /i drop ] ignore-errors ] unit-test +[ ] [ [ 100000000000000000 0 /i drop ] ignore-errors ] unit-test [ -2 ] [ 1 bitnot ] unit-test [ -2 ] [ 1 >bignum bitnot ] unit-test diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 62893e2618..7c30012a19 100755 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -105,6 +105,6 @@ unit-test ! [ dup number>string string>number = ] all? ! ] unit-test -[ 1 1 >base ] unit-test-fails -[ 1 0 >base ] unit-test-fails -[ 1 -1 >base ] unit-test-fails +[ 1 1 >base ] must-fail +[ 1 0 >base ] must-fail +[ 1 -1 >base ] must-fail diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index f543c08744..d0dfd2c0be 100755 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -4,7 +4,7 @@ IN: temporary TUPLE: testing x y z ; -[ save-image-and-exit ] unit-test-fails +[ save-image-and-exit ] must-fail [ ] [ num-types get [ diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index f503528a24..eb04e329d9 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -93,12 +93,12 @@ IN: temporary ! Funny bug [ 2 ] [ "IN: temporary : \0. 2 ; \0." eval ] unit-test - [ "IN: temporary : missing-- ( a b ) ;" eval ] unit-test-fails + [ "IN: temporary : missing-- ( a b ) ;" eval ] must-fail ! These should throw errors - [ "HEX: zzz" eval ] unit-test-fails - [ "OCT: 999" eval ] unit-test-fails - [ "BIN: --0" eval ] unit-test-fails + [ "HEX: zzz" eval ] must-fail + [ "OCT: 999" eval ] must-fail + [ "BIN: --0" eval ] must-fail ! Another funny bug [ t ] [ @@ -205,12 +205,10 @@ IN: temporary "a" source-files get delete-at - [ t ] [ - [ - "IN: temporary : x ; : y 3 throw ; this is an error" - "a" parse-stream - ] catch parse-error? - ] unit-test + [ + "IN: temporary : x ; : y 3 throw ; this is an error" + "a" parse-stream + ] [ parse-error? ] must-fail-with [ t ] [ "y" "temporary" lookup >boolean @@ -307,62 +305,50 @@ IN: temporary "killer?" "temporary" lookup >boolean ] unit-test - [ t ] [ - [ - "IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?" - "removing-the-predicate" parse-stream - ] catch [ redefine-error? ] is? - ] unit-test + [ + "IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?" + "removing-the-predicate" parse-stream + ] [ [ redefine-error? ] is? ] must-fail-with - [ t ] [ - [ - "IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;" - "redefining-a-class-1" parse-stream - ] catch [ redefine-error? ] is? - ] unit-test + [ + "IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;" + "redefining-a-class-1" parse-stream + ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test" "redefining-a-class-2" parse-stream drop ] unit-test - [ t ] [ - [ - "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" - "redefining-a-class-3" parse-stream drop - ] catch [ redefine-error? ] is? - ] unit-test + [ + "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" + "redefining-a-class-3" parse-stream drop + ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ "IN: temporary TUPLE: class-fwd-test ;" "redefining-a-class-3" parse-stream drop ] unit-test - [ t ] [ - [ - "IN: temporary \\ class-fwd-test" - "redefining-a-class-3" parse-stream drop - ] catch [ no-word? ] is? - ] unit-test + [ + "IN: temporary \\ class-fwd-test" + "redefining-a-class-3" parse-stream drop + ] [ [ no-word? ] is? ] must-fail-with [ ] [ "IN: temporary TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" "redefining-a-class-3" parse-stream drop ] unit-test - [ t ] [ - [ - "IN: temporary \\ class-fwd-test" - "redefining-a-class-3" parse-stream drop - ] catch [ no-word? ] is? - ] unit-test + [ + "IN: temporary \\ class-fwd-test" + "redefining-a-class-3" parse-stream drop + ] [ [ no-word? ] is? ] must-fail-with - [ t ] [ - [ - "IN: temporary : foo ; TUPLE: foo ;" - "redefining-a-class-4" parse-stream drop - ] catch [ redefine-error? ] is? - ] unit-test + [ + "IN: temporary : foo ; TUPLE: foo ;" + "redefining-a-class-4" parse-stream drop + ] [ [ redefine-error? ] is? ] must-fail-with ] with-file-vocabs [ diff --git a/core/quotations/quotations-tests.factor b/core/quotations/quotations-tests.factor index f1cc6cd828..d357fb70ff 100644 --- a/core/quotations/quotations-tests.factor +++ b/core/quotations/quotations-tests.factor @@ -15,4 +15,4 @@ IN: temporary [ [ "hi" ] ] [ "hi" 1quotation ] unit-test -[ 1 \ + curry ] unit-test-fails +[ 1 \ + curry ] must-fail diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 73ae4737ba..40b2fef85e 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -83,8 +83,8 @@ unit-test [ [ 1 2 3 4 ] ] [ [ 1 2 3 ] [ 4 ] append ] unit-test [ [ 1 2 3 4 ] ] [ [ 1 2 3 ] { 4 } append ] unit-test -[ "a" -1 append ] unit-test-fails -[ -1 "a" append ] unit-test-fails +[ "a" -1 append ] must-fail +[ -1 "a" append ] must-fail [ [ ] ] [ 1 [ ] remove ] unit-test [ [ ] ] [ 1 [ 1 ] remove ] unit-test @@ -119,7 +119,7 @@ unit-test [ V{ 0 1 4 5 } ] [ 6 >vector 2 4 pick delete-slice ] unit-test -[ 6 >vector 2 8 pick delete-slice ] unit-test-fails +[ 6 >vector 2 8 pick delete-slice ] must-fail [ V{ } ] [ 6 >vector 0 6 pick delete-slice ] unit-test @@ -173,7 +173,7 @@ unit-test [ V{ "C" } V{ "c" } ] [ { "a" "b" "C" } { "a" "b" "c" } drop-prefix [ >vector ] 2apply ] unit-test -[ -1 1 "abc" ] unit-test-fails +[ -1 1 "abc" ] must-fail [ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] 2apply ] unit-test @@ -195,8 +195,8 @@ unit-test ! Pathological case [ "ihbye" ] [ "hi" "bye" append ] unit-test -[ -10 "hi" "bye" copy ] unit-test-fails -[ 10 "hi" "bye" copy ] unit-test-fails +[ -10 "hi" "bye" copy ] must-fail +[ 10 "hi" "bye" copy ] must-fail [ V{ 1 2 3 5 6 } ] [ 3 V{ 1 2 3 4 5 6 } clone [ delete-nth ] keep @@ -228,13 +228,13 @@ unit-test [ SBUF" \0\0\0" ] [ 3 SBUF" " new ] unit-test [ 0 ] [ f length ] unit-test -[ f first ] unit-test-fails +[ f first ] must-fail [ 3 ] [ 3 10 nth ] unit-test [ 3 ] [ 3 10 nth-unsafe ] unit-test -[ -3 10 nth ] unit-test-fails -[ 11 10 nth ] unit-test-fails +[ -3 10 nth ] must-fail +[ 11 10 nth ] must-fail -[ -1./0. 0 delete-nth ] unit-test-fails +[ -1./0. 0 delete-nth ] must-fail [ "" ] [ "" [ CHAR: \s = ] trim ] unit-test [ "" ] [ "" [ CHAR: \s = ] left-trim ] unit-test [ "" ] [ "" [ CHAR: \s = ] right-trim ] unit-test diff --git a/core/splitting/splitting-tests.factor b/core/splitting/splitting-tests.factor index 3ca78248ab..2b6107e08b 100644 --- a/core/splitting/splitting-tests.factor +++ b/core/splitting/splitting-tests.factor @@ -1,7 +1,7 @@ USING: splitting tools.test ; IN: temporary -[ { 1 2 3 } 0 group ] unit-test-fails +[ { 1 2 3 } 0 group ] must-fail [ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 985c025827..90e74275ff 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -4,7 +4,7 @@ IN: temporary [ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test -[ ] [ 10 [ [ -1000000 ] catch drop ] times ] unit-test +[ ] [ 10 [ [ -1000000 ] ignore-errors ] times ] unit-test [ "abc" ] [ [ "a" "b" "c" ] [ [ % ] each ] "" make ] unit-test @@ -31,7 +31,7 @@ IN: temporary [ t ] [ "abc" "abd" <=> 0 < ] unit-test [ t ] [ "z" "abd" <=> 0 > ] unit-test -[ f ] [ [ 0 10 "hello" subseq ] catch not ] unit-test +[ 0 10 "hello" subseq ] must-fail [ "Replacing+spaces+with+plus" ] [ @@ -43,8 +43,8 @@ unit-test [ "05" ] [ "5" 2 CHAR: 0 pad-left ] unit-test [ "666" ] [ "666" 2 CHAR: 0 pad-left ] unit-test -[ 1 "" nth ] unit-test-fails -[ -6 "hello" nth ] unit-test-fails +[ 1 "" nth ] must-fail +[ -6 "hello" nth ] must-fail [ t ] [ "hello world" dup >vector >string = ] unit-test @@ -55,8 +55,7 @@ unit-test [ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test ! Random tester found this -[ { "kernel-error" 3 12 -7 } ] -[ [ 2 -7 resize-string ] catch ] unit-test +[ 2 -7 resize-string ] [ { "kernel-error" 3 12 -7 } = ] must-fail-with ! Make sure 24-bit strings work "hello world" "s" set diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index b1b2f86a47..379b10ce88 100755 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -9,4 +9,4 @@ IN: temporary yield [ ] [ 0.3 sleep ] unit-test -[ "hey" sleep ] unit-test-fails +[ "hey" sleep ] must-fail diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index 627ee5562f..dede1a2136 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -55,7 +55,7 @@ C: point "IN: temporary TUPLE: point z y ;" eval -[ "p" get point-x ] unit-test-fails +[ "p" get point-x ] must-fail [ 200 ] [ "p" get point-y ] unit-test [ 300 ] [ "p" get "point-z" "temporary" lookup execute ] unit-test @@ -97,7 +97,7 @@ TUPLE: delegate-clone ; [ f ] [ \ tuple \ delegate-clone class< ] unit-test ! Compiler regression -[ t ] [ [ t length ] catch no-method-object ] unit-test +[ t length ] [ no-method-object t eq? ] must-fail-with [ "" ] [ "TUPLE: constructor-test ; C: constructor-test" eval word word-name ] unit-test @@ -204,15 +204,15 @@ SYMBOL: not-a-tuple-class [ "IN: temporary C: not-a-tuple-class" eval -] unit-test-fails +] must-fail [ t ] [ "not-a-tuple-class" "temporary" lookup symbol? ] unit-test ! Missing check -[ not-a-tuple-class construct-boa ] unit-test-fails -[ not-a-tuple-class construct-empty ] unit-test-fails +[ not-a-tuple-class construct-boa ] must-fail +[ not-a-tuple-class construct-empty ] must-fail TUPLE: erg's-reshape-problem a b c d ; @@ -234,8 +234,6 @@ C: erg's-reshape-problem [ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test -[ t ] [ - [ - "IN: temporary SYMBOL: not-a-class C: not-a-class" eval - ] catch [ check-tuple? ] is? -] unit-test +[ + "IN: temporary SYMBOL: not-a-class C: not-a-class" eval +] [ [ check-tuple? ] is? ] must-fail-with diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index 4c57c238b4..b56cee1b34 100755 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -3,25 +3,25 @@ sequences sequences.private strings tools.test vectors continuations random growable classes ; IN: temporary -[ ] [ 10 [ [ -1000000 ] catch drop ] times ] unit-test +[ ] [ 10 [ [ -1000000 ] ignore-errors ] times ] unit-test [ 3 ] [ [ t f t ] length ] unit-test [ 3 ] [ V{ t f t } length ] unit-test -[ -3 V{ } nth ] unit-test-fails -[ 3 V{ } nth ] unit-test-fails -[ 3 54.3 nth ] unit-test-fails +[ -3 V{ } nth ] must-fail +[ 3 V{ } nth ] must-fail +[ 3 54.3 nth ] must-fail -[ "hey" [ 1 2 ] set-length ] unit-test-fails -[ "hey" V{ 1 2 } set-length ] unit-test-fails +[ "hey" [ 1 2 ] set-length ] must-fail +[ "hey" V{ 1 2 } set-length ] must-fail [ 3 ] [ 3 0 [ set-length ] keep length ] unit-test [ "yo" ] [ "yo" 4 1 [ set-nth ] keep 4 swap nth ] unit-test -[ 1 V{ } nth ] unit-test-fails -[ -1 V{ } set-length ] unit-test-fails +[ 1 V{ } nth ] must-fail +[ -1 V{ } set-length ] must-fail [ V{ } ] [ [ ] >vector ] unit-test [ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test @@ -64,8 +64,8 @@ IN: temporary [ V{ 2 3 } ] [ "funny-stack" get pop ] unit-test [ V{ 1 5 } ] [ "funny-stack" get peek ] unit-test [ V{ 1 5 } ] [ "funny-stack" get pop ] unit-test -[ "funny-stack" get pop ] unit-test-fails -[ "funny-stack" get pop ] unit-test-fails +[ "funny-stack" get pop ] must-fail +[ "funny-stack" get pop ] must-fail [ ] [ "funky" "funny-stack" get push ] unit-test [ "funky" ] [ "funny-stack" get pop ] unit-test diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 560affa566..764f14e45f 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -18,16 +18,6 @@ debugger compiler.units ; [ t ] [ "kernel" f >vocab-link "kernel" vocab = ] unit-test -! This vocab should not exist, but just in case... -[ ] [ [ "core" forget-vocab ] with-compilation-unit ] unit-test - -2 [ - [ T{ no-vocab f "core" } ] - [ [ "core" require ] catch ] unit-test -] times - -[ f ] [ "core" vocab ] unit-test - [ t ] [ "kernel" vocab-files "kernel" vocab vocab-files @@ -59,7 +49,7 @@ IN: temporary 0 "count-me" set-global 2 [ - [ "vocabs.loader.test.a" require ] unit-test-fails + [ "vocabs.loader.test.a" require ] must-fail [ f ] [ "vocabs.loader.test.a" vocab-source-loaded? ] unit-test @@ -97,7 +87,7 @@ IN: temporary ] with-compilation-unit ] unit-test -[ "vocabs.loader.test.b" require ] unit-test-fails +[ "vocabs.loader.test.b" require ] must-fail [ 1 ] [ "count-me" get-global ] unit-test diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 92f5284c49..f29d21cd9f 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -110,7 +110,7 @@ M: array freakish ; [ t ] [ \ bar \ freakish usage member? ] unit-test DEFER: x -[ t ] [ [ x ] catch undefined? ] unit-test +[ x ] [ undefined? ] must-fail-with [ ] [ "no-loc" "temporary" create drop ] unit-test [ f ] [ "no-loc" "temporary" lookup where ] unit-test @@ -141,10 +141,8 @@ SYMBOL: quot-uses-b [ { + } ] [ \ quot-uses-b uses ] unit-test -[ t ] [ - [ "IN: temporary : undef-test ; << undef-test >>" eval ] catch - [ undefined? ] is? -] unit-test +[ "IN: temporary : undef-test ; << undef-test >>" eval ] +[ [ undefined? ] is? ] must-fail-with [ ] [ "IN: temporary GENERIC: symbol-generic" eval diff --git a/extra/bitfields/bitfields-tests.factor b/extra/bitfields/bitfields-tests.factor index 6c82ec0323..8a3bb1f043 100644 --- a/extra/bitfields/bitfields-tests.factor +++ b/extra/bitfields/bitfields-tests.factor @@ -10,12 +10,12 @@ SAFE-BITFIELD: foo bar:5 baz:10 111 bing:2 ; [ 855 ] [ 21 852 3 855 swap with-foo-baz foo-baz ] unit-test [ 1 ] [ 21 852 3 1 swap with-foo-bing foo-bing ] unit-test -[ 100 0 0 ] unit-test-fails -[ 0 5000 0 ] unit-test-fails -[ 0 0 10 ] unit-test-fails +[ 100 0 0 ] must-fail +[ 0 5000 0 ] must-fail +[ 0 0 10 ] must-fail -[ 100 0 with-foo-bar ] unit-test-fails -[ 5000 0 with-foo-baz ] unit-test-fails -[ 10 0 with-foo-bing ] unit-test-fails +[ 100 0 with-foo-bar ] must-fail +[ 5000 0 with-foo-baz ] must-fail +[ 10 0 with-foo-bing ] must-fail [ BIN: 00101100000000111111 ] [ BIN: 101 BIN: 1000000001 BIN: 11 ] unit-test diff --git a/extra/bootstrap/io/io.factor b/extra/bootstrap/io/io.factor index 4d5440e546..065f7dd5c4 100755 --- a/extra/bootstrap/io/io.factor +++ b/extra/bootstrap/io/io.factor @@ -10,5 +10,3 @@ IN: bootstrap.io { [ wince? ] [ "windows.ce" ] } } cond append require ] when - -"vocabs.monitor" require diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index fbb60b2d49..3b0cfc8455 100644 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -1,14 +1,14 @@ USING: arrays calendar kernel math sequences tools.test continuations system ; -[ "invalid timestamp" ] [ [ 2004 12 32 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 2 30 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2003 2 29 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 -2 9 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 12 0 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 12 1 24 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 12 1 23 60 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 12 1 23 59 60 0 0 make-timestamp ] catch ] unit-test +[ 2004 12 32 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 2 30 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2003 2 29 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 -2 9 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 12 0 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 12 1 24 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 12 1 23 60 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 12 1 23 59 60 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 1900 leap-year? ] unit-test [ t ] [ 1904 leap-year? ] unit-test diff --git a/extra/circular/circular-tests.factor b/extra/circular/circular-tests.factor index 01504a0e8a..8ca4574885 100644 --- a/extra/circular/circular-tests.factor +++ b/extra/circular/circular-tests.factor @@ -9,7 +9,7 @@ circular strings ; [ CHAR: t ] [ "test" 0 swap nth ] unit-test [ "test" ] [ "test" >string ] unit-test -[ "test" 5 swap nth ] unit-test-fails +[ "test" 5 swap nth ] must-fail [ CHAR: e ] [ "test" 5 swap nth-unsafe ] unit-test [ [ 1 2 3 ] ] [ { 1 2 3 } [ ] like ] unit-test @@ -18,7 +18,7 @@ circular strings ; [ [ 3 1 2 ] ] [ { 1 2 3 } -100 over change-circular-start [ ] like ] unit-test [ "fob" ] [ "foo" CHAR: b 2 pick set-nth >string ] unit-test -[ "foo" CHAR: b 3 rot set-nth ] unit-test-fails +[ "foo" CHAR: b 3 rot set-nth ] must-fail [ "boo" ] [ "foo" CHAR: b 3 pick set-nth-unsafe >string ] unit-test [ "ornact" ] [ "factor" 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index deeb105758..235f441b8b 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -8,26 +8,25 @@ IN: temporary [ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test [ 328350 ] [ 100 [ sq ] sigma ] unit-test -: infers? [ infer drop ] curry catch not ; - [ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test { 6 2 } [ 1 2 [ 5 + ] dip ] unit-test { 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test -{ t } [ [ [ 99 ] 1 2 3 4 5 5 nslip ] infers? ] unit-test + +[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer { 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test -{ t } [ [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] infers? ] unit-test +[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test -{ t } [ [ 1 2 { 3 4 } [ + + ] 2 map-withn ] infers? ] unit-test +[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer { { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test { { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test -{ t } [ [ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] infers? ] unit-test +[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer { 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test [ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test [ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test -[ t ] [ [ [ sq ] 3apply ] infers? ] unit-test +[ [ sq ] 3apply ] must-infer [ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test -[ t ] [ [ [ dup 2^ 2array ] 5 napply ] infers? ] unit-test +[ [ dup 2^ 2array ] 5 napply ] must-infer ! && diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor index dafbafbc5b..f04811b72a 100644 --- a/extra/concurrency/concurrency-docs.factor +++ b/extra/concurrency/concurrency-docs.factor @@ -146,7 +146,7 @@ ARTICLE: { "concurrency" "exceptions" } "Exceptions" "A process can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the process will terminate. For example:" { $code "[ 1 0 / \"This will not print\" print ] spawn" } "Processes can be linked so that a parent process can receive the exception that caused the child process to terminate. In this way 'supervisor' processes can be created that are notified when child processes terminate and possibly restart them.\n\nThe easiest way to form this link is using " { $link spawn-link } ". This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent process can catch it:" -{ $code "[\n [ 1 0 / \"This will not print\" print ] spawn-link drop\n receive\n] catch [ \"Exception caught.\" print ] when" } +{ $code "[\n [ 1 0 / \"This will not print\" print ] spawn-link drop\n receive\n] [ \"Exception caught.\" print ] recover" } "Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ; ARTICLE: { "concurrency" "futures" } "Futures" diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor index a9d4b39854..2f9b6605d7 100644 --- a/extra/concurrency/concurrency-tests.factor +++ b/extra/concurrency/concurrency-tests.factor @@ -67,15 +67,12 @@ IN: temporary ] unit-test -[ "crash" ] [ +[ [ - [ - "crash" throw - ] spawn-link drop - receive - ] - catch -] unit-test + "crash" throw + ] spawn-link drop + receive +] [ "crash" = ] must-fail-with [ 50 ] [ [ 50 ] future ?future @@ -115,7 +112,7 @@ SYMBOL: value ! this is fixed (via a timeout). ! [ ! [ "this should propogate" throw ] future ?future -! ] unit-test-fails +! ] must-fail [ ] [ [ "this should not propogate" throw ] future drop diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index bc0d01956f..8d842f15d0 100644 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -166,7 +166,7 @@ M: process send ( message process -- ) PRIVATE> : spawn-link ( quot -- process ) - [ catch [ rethrow-linked ] when* ] curry + [ [ rethrow-linked ] recover ] curry [ ((spawn)) ] curry (spawn-link) ; inline "parent-test" parse-stream drop - ] catch [ :1 ] when + ] [ :1 ] recover ] unit-test [ "xxx" ] [ "yyy" article-parent ] unit-test diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index a61be734fc..31e7c5f78a 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -3,7 +3,7 @@ math.functions math.constants ; IN: inverse-tests [ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test -[ { 3 4 } [ dup 2array ] undo ] unit-test-fails +[ { 3 4 } [ dup 2array ] undo ] must-fail TUPLE: foo bar baz ; @@ -15,7 +15,7 @@ C: foo [ t ] [ { 3 3 } [ 2same ] matches? ] unit-test [ f ] [ { 3 4 } [ 2same ] matches? ] unit-test -[ [ 2same ] matches? ] unit-test-fails +[ [ 2same ] matches? ] must-fail : something ( array -- num ) { @@ -25,9 +25,9 @@ C: foo [ 5 ] [ { 1 2 2 } something ] unit-test [ 6 ] [ { 2 3 } something ] unit-test -[ { 1 } something ] unit-test-fails +[ { 1 } something ] must-fail -[ 1 2 [ eq? ] undo ] unit-test-fails +[ 1 2 [ eq? ] undo ] must-fail : f>c ( *fahrenheit -- *celsius ) 32 - 1.8 / ; diff --git a/extra/io/buffers/buffers-tests.factor b/extra/io/buffers/buffers-tests.factor index 6fcdc86423..c9203d9ef8 100755 --- a/extra/io/buffers/buffers-tests.factor +++ b/extra/io/buffers/buffers-tests.factor @@ -75,5 +75,5 @@ sequences tools.test namespaces ; "b" get buffer-free 100 "b" set -[ 1000 "b" get n>buffer ] unit-test-fails +[ 1000 "b" get n>buffer ] must-fail "b" get buffer-free diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index a01481ecdc..f0547961bc 100644 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -1,9 +1,9 @@ USING: io io.mmap io.files kernel tools.test continuations sequences ; IN: temporary -[ "mmap-test-file.txt" resource-path delete-file ] catch drop +[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors [ ] [ "mmap-test-file.txt" resource-path [ "12345" write ] with-stream ] unit-test [ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test [ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test [ "22345" ] [ "mmap-test-file.txt" resource-path file-contents ] unit-test -[ "mmap-test-file.txt" resource-path delete-file ] catch drop +[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index fec97baa5a..eb3038e1b5 100755 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -1,8 +1,8 @@ IN: temporary USING: io.unix.launcher tools.test ; -[ "" tokenize-command ] unit-test-fails -[ " " tokenize-command ] unit-test-fails +[ "" tokenize-command ] must-fail +[ " " tokenize-command ] must-fail [ { "a" } ] [ "a" tokenize-command ] unit-test [ { "abc" } ] [ "abc" tokenize-command ] unit-test [ { "abc" } ] [ "abc " tokenize-command ] unit-test @@ -14,8 +14,8 @@ USING: io.unix.launcher tools.test ; [ { "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test [ { "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test [ { "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test -[ "'abc def' \"hey" tokenize-command ] unit-test-fails -[ "'abc def" tokenize-command ] unit-test-fails +[ "'abc def' \"hey" tokenize-command ] must-fail +[ "'abc def" tokenize-command ] must-fail [ { "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test [ diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 9c4aced03f..55f5f01abc 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -3,7 +3,7 @@ USING: kernel io.backend io.monitors io.monitors.private io.files io.buffers io.nonblocking io.unix.backend io.unix.select io.unix.launcher unix.linux.inotify assocs namespaces threads -continuations init math alien.c-types alien ; +continuations init math alien.c-types alien vocabs.loader ; IN: io.unix.linux TUPLE: linux-io ; @@ -134,4 +134,6 @@ M: linux-io init-io ( -- ) T{ linux-io } set-io-backend -[ start-wait-thread ] "io.unix.linux" add-init-hook \ No newline at end of file +[ start-wait-thread ] "io.unix.linux" add-init-hook + +"vocabs.monitor" require \ No newline at end of file diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index 8a621f8f48..5a93257949 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -7,7 +7,7 @@ IN: temporary [ [ "unix-domain-socket-test" resource-path delete-file - ] catch drop + ] ignore-errors "unix-domain-socket-test" resource-path [ @@ -36,7 +36,7 @@ yield ! Unix domain datagram sockets [ "unix-domain-datagram-test" resource-path delete-file -] catch drop +] ignore-errors : server-addr "unix-domain-datagram-test" resource-path ; : client-addr "unix-domain-datagram-test-2" resource-path ; @@ -75,7 +75,7 @@ yield [ "unix-domain-datagram-test-2" resource-path delete-file -] catch drop +] ignore-errors client-addr "d" set @@ -110,7 +110,7 @@ client-addr [ "unix-domain-datagram-test-3" resource-path delete-file -] catch drop +] ignore-errors "unix-domain-datagram-test-2" resource-path delete-file @@ -118,29 +118,29 @@ client-addr [ B{ 1 2 3 } "unix-domain-datagram-test-3" "d" get send -] unit-test-fails +] must-fail [ ] [ "d" get dispose ] unit-test ! See what happens on send/receive after close -[ "d" get receive ] unit-test-fails +[ "d" get receive ] must-fail -[ B{ 1 2 } server-addr "d" get send ] unit-test-fails +[ B{ 1 2 } server-addr "d" get send ] must-fail ! Invalid parameter tests [ image [ stdio get accept ] with-stream -] unit-test-fails +] must-fail [ image [ stdio get receive ] with-stream -] unit-test-fails +] must-fail [ image [ B{ 1 2 } server-addr stdio get send ] with-stream -] unit-test-fails +] must-fail diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index b957aa2fca..be57a398a2 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman, ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USE: vocabs.loader USE: io.windows USE: io.windows.nt.backend USE: io.windows.nt.files @@ -11,3 +12,5 @@ USE: io.windows.mmap USE: io.backend T{ windows-nt-io } set-io-backend + +"vocabs.monitor" require diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor index 5b4355986f..44c682e671 100755 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -189,7 +189,7 @@ SYMBOL: line : with-infinite-loop ( quot timeout -- quot timeout ) "looping" print flush - over catch drop dup sleep with-infinite-loop ; + over [ drop ] recover dup sleep with-infinite-loop ; : start-irc ( irc-client -- ) ! [ [ do-irc ] curry 3000 with-infinite-loop ] with-scope ; diff --git a/extra/math/complex/complex-tests.factor b/extra/math/complex/complex-tests.factor index be512e5052..e8535d0637 100755 --- a/extra/math/complex/complex-tests.factor +++ b/extra/math/complex/complex-tests.factor @@ -2,8 +2,8 @@ USING: kernel math math.constants math.functions tools.test prettyprint ; IN: temporary -[ 1 C{ 0 1 } rect> ] unit-test-fails -[ C{ 0 1 } 1 rect> ] unit-test-fails +[ 1 C{ 0 1 } rect> ] must-fail +[ C{ 0 1 } 1 rect> ] must-fail [ f ] [ C{ 5 12.5 } 5 = ] unit-test [ t ] [ C{ 1.0 2.0 } C{ 1 2 } = ] unit-test diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor index 439eaace6f..6f4dc42593 100755 --- a/extra/math/functions/functions-tests.factor +++ b/extra/math/functions/functions-tests.factor @@ -73,7 +73,7 @@ IN: temporary [ 3 ] [ 5 7 mod-inv ] unit-test [ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test -[ 2 10 mod-inv ] unit-test-fails +[ 2 10 mod-inv ] must-fail [ t ] [ 0 0 ^ fp-nan? ] unit-test [ 1 ] [ 10 0 ^ ] unit-test diff --git a/extra/memoize/memoize-tests.factor b/extra/memoize/memoize-tests.factor index f5a7f85edb..dbd2d3a16a 100644 --- a/extra/memoize/memoize-tests.factor +++ b/extra/memoize/memoize-tests.factor @@ -7,4 +7,4 @@ MEMO: fib ( m -- n ) [ 89 ] [ 10 fib ] unit-test -[ "USING: kernel math memoize ; MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] unit-test-fails +[ "USING: kernel math memoize ; MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor index d2af88d02a..a0769dffda 100755 --- a/extra/multi-methods/multi-methods-tests.factor +++ b/extra/multi-methods/multi-methods-tests.factor @@ -52,7 +52,7 @@ METHOD: beats? { thing thing } f ; : play ( obj1 obj2 -- ? ) beats? 2nip ; -[ { } 3 play ] unit-test-fails +[ { } 3 play ] must-fail [ t ] [ error get no-method? ] unit-test [ ] [ error get error. ] unit-test [ t ] [ T{ paper } T{ scissors } play ] unit-test diff --git a/extra/parser-combinators/parser-combinators-tests.factor b/extra/parser-combinators/parser-combinators-tests.factor index fc8cec770b..a1f82391a0 100644 --- a/extra/parser-combinators/parser-combinators-tests.factor +++ b/extra/parser-combinators/parser-combinators-tests.factor @@ -76,7 +76,7 @@ IN: scratchpad [ "begin1" "begin" token some parse -] unit-test-fails +] must-fail { "begin" } [ "begin" "begin" token some parse diff --git a/extra/regexp/regexp-tests.factor b/extra/regexp/regexp-tests.factor index 9c0ed5bd81..f6e7c05910 100755 --- a/extra/regexp/regexp-tests.factor +++ b/extra/regexp/regexp-tests.factor @@ -95,7 +95,7 @@ IN: regexp-tests [ t ] [ "]" "[]]" f matches? ] unit-test [ f ] [ "]" "[^]]" f matches? ] unit-test -! [ "^" "[^]" f matches? ] unit-test-fails +! [ "^" "[^]" f matches? ] must-fail [ t ] [ "^" "[]^]" f matches? ] unit-test [ t ] [ "]" "[]^]" f matches? ] unit-test diff --git a/extra/roman/roman-tests.factor b/extra/roman/roman-tests.factor index e850411726..a15dcef354 100644 --- a/extra/roman/roman-tests.factor +++ b/extra/roman/roman-tests.factor @@ -28,11 +28,11 @@ USING: arrays kernel math roman roman.private sequences tools.test ; [ 1666 ] [ 1666 >roman roman> ] unit-test [ 3444 ] [ 3444 >roman roman> ] unit-test [ 3999 ] [ 3999 >roman roman> ] unit-test -[ 0 >roman ] unit-test-fails -[ 4000 >roman ] unit-test-fails +[ 0 >roman ] must-fail +[ 4000 >roman ] must-fail [ "vi" ] [ "iii" "iii" roman+ ] unit-test [ "viii" ] [ "x" "ii" roman- ] unit-test [ "ix" ] [ "iii" "iii" roman* ] unit-test [ "i" ] [ "iii" "ii" roman/i ] unit-test [ "i" "ii" ] [ "v" "iii" roman/mod ] unit-test -[ "iii" "iii" roman- ] unit-test-fails +[ "iii" "iii" roman- ] must-fail diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 717f463c45..d0bc0a9e52 100644 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -38,7 +38,7 @@ math.functions tools.test strings ; [ f ] [ { "asdf" "bsdf" } singleton? ] unit-test [ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test -[ V{ } [ delete-random drop ] keep length ] unit-test-fails +[ V{ } [ delete-random drop ] keep length ] must-fail [ { 1 9 25 } ] [ { 1 3 5 6 } [ sq ] [ even? ] map-until ] unit-test [ { 2 4 } ] [ { 2 4 1 3 } [ even? ] take-while ] unit-test diff --git a/extra/tetris/board/board-tests.factor b/extra/tetris/board/board-tests.factor index 3a870e621e..bd8789c4d6 100644 --- a/extra/tetris/board/board-tests.factor +++ b/extra/tetris/board/board-tests.factor @@ -5,7 +5,7 @@ colors ; [ { { f f } { f f } { f f } } ] [ 2 3 board-rows ] unit-test [ 1 { f f } ] [ 2 3 { 1 1 } board@block ] unit-test [ f ] [ 2 3 { 1 1 } board-block ] unit-test -[ 2 3 { 2 3 } board-block ] unit-test-fails +[ 2 3 { 2 3 } board-block ] must-fail red 1array [ 2 3 dup { 1 1 } red board-set-block { 1 1 } board-block ] unit-test [ t ] [ 2 3 { 1 1 } block-free? ] unit-test [ f ] [ 2 3 dup { 1 1 } red board-set-block { 1 1 } block-free? ] unit-test diff --git a/extra/tools/interpreter/interpreter-tests.factor b/extra/tools/interpreter/interpreter-tests.factor index 3976ada845..e7fe7854fa 100644 --- a/extra/tools/interpreter/interpreter-tests.factor +++ b/extra/tools/interpreter/interpreter-tests.factor @@ -99,7 +99,7 @@ IN: temporary [ [ [ 3 swap continue-with ] callcc1 2 * ] test-interpreter ] unit-test [ { 6 } ] -[ [ [ 3 throw ] catch 2 * ] test-interpreter ] unit-test +[ [ [ 3 throw ] [ 2 * ] recover ] test-interpreter ] unit-test [ { "{ 1 2 3 }\n" } ] [ [ [ { 1 2 3 } . ] string-out ] test-interpreter diff --git a/extra/tools/test/inference/inference.factor b/extra/tools/test/inference/inference.factor index 17ff7e1acd..cc77f4910d 100755 --- a/extra/tools/test/inference/inference.factor +++ b/extra/tools/test/inference/inference.factor @@ -10,7 +10,6 @@ IN: tools.test.inference : unit-test-effect ( effect quot -- ) >r 1quotation r> [ infer short-effect ] curry unit-test ; -: must-infer ( word -- ) - dup "declared-effect" word-prop - dup effect-in length swap effect-out length 2array - swap 1quotation unit-test-effect ; +: must-infer ( word/quot -- ) + dup word? [ 1quotation ] when + [ infer drop ] curry [ ] swap unit-test ; diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index aa994e91d2..1037323ddb 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -42,6 +42,9 @@ M: expected-error summary : must-fail ( quot -- ) [ drop t ] must-fail-with ; +: ignore-errors ( quot -- ) + [ drop ] recover ; inline + : run-test ( path -- failures ) [ "temporary" forget-vocab ] with-compilation-unit [ diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor index eab85209cc..56c90f760f 100755 --- a/extra/ui/tools/listener/listener-tests.factor +++ b/extra/ui/tools/listener/listener-tests.factor @@ -25,7 +25,7 @@ timers [ init-timers ] unless [ ] [ "SYMBOL:" "i" get set-editor-string ] unit-test [ ] [ - "i" get [ { "SYMBOL:" } parse-lines ] catch go-to-error + "i" get [ { "SYMBOL:" } parse-lines ] [ go-to-error ] recover ] unit-test [ t ] [ diff --git a/extra/xml/test/errors.factor b/extra/xml/test/errors.factor index 596f1e6c43..c0a60d8a3f 100644 --- a/extra/xml/test/errors.factor +++ b/extra/xml/test/errors.factor @@ -1,7 +1,7 @@ USING: continuations xml xml.errors tools.test kernel arrays xml.data state-parser quotations ; : xml-error-test ( expected-error xml-string -- ) - swap 1array >quotation swap [ [ string>xml ] catch nip ] curry unit-test ; + [ string>xml ] curry swap [ = ] curry must-fail-with ; T{ no-entity T{ parsing-error f 1 10 } "nbsp" } " " xml-error-test T{ mismatched T{ parsing-error f 1 8 } T{ name f "" "x" "" } T{ name f "" "y" "" } diff --git a/extra/xml/test/test.factor b/extra/xml/test/test.factor index ec59d3564e..0198ebacb7 100644 --- a/extra/xml/test/test.factor +++ b/extra/xml/test/test.factor @@ -17,7 +17,7 @@ SYMBOL: xml-file xml-file get T{ name f "" "this" "http://d.de" } swap at ] unit-test [ t ] [ xml-file get tag-children second contained-tag? ] unit-test -[ t ] [ [ "" string>xml ] catch xml-parse-error? ] unit-test +[ "" string>xml ] [ xml-parse-error? ] must-fail-with [ T{ comment f "This is where the fun begins!" } ] [ xml-file get xml-before [ comment? ] find nip ] unit-test From f7ca140c230af21ad26a00e0320f056783d56a6c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 13:51:16 -0600 Subject: [PATCH 58/62] Fix compiled-xref --- core/words/words.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/words/words.factor b/core/words/words.factor index f628d68bee..bd49a3d855 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -99,7 +99,7 @@ SYMBOL: compiled-crossref compiled-crossref global [ H{ } assoc-like ] change-at : compiled-xref ( word dependencies -- ) - [ crossref? ] subset + [ drop crossref? ] assoc-subset 2dup "compiled-uses" set-word-prop compiled-crossref get add-vertex* ; From 31b863f8b20da0a8850b2eabcafa0625ff13d035 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 13:51:23 -0600 Subject: [PATCH 59/62] Fix docs load error --- extra/tools/test/test-docs.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) mode change 100644 => 100755 extra/tools/test/test-docs.factor diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor old mode 100644 new mode 100755 index 32825c965d..147e795861 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -10,7 +10,8 @@ $nl $nl "If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run. Test harness files consist mostly of calls to the following two words:" { $subsection unit-test } -{ $subsection unit-test-fails } +{ $subsection must-fail } +{ $subsection must-fail-with } "The following words run test harness files; any test failures are collected and printed at the end:" { $subsection test } { $subsection test-all } ; @@ -21,7 +22,7 @@ HELP: unit-test { $values { "output" "a sequence of expected stack elements" } { "input" "a quotation run with an empty stack" } } { $description "Runs a quotation with an empty stack, comparing the resulting stack with " { $snippet "output" } ". Elements are compared using " { $link = } ". Throws an error if the expected stack does not match the resulting stack." } ; -HELP: unit-test-fails +HELP: must-fail { $values { "quot" "a quotation run with an empty stack" } } { $description "Runs a quotation with an empty stack, expecting it to throw an error. If the quotation throws an error, this word returns normally. If the quotation does not throw an error, this word " { $emphasis "does" } " raise an error." } { $notes "This word is used to test boundary conditions and fail-fast behavior." } ; From b18a4632852bee2b421c2e35df254e84e738d1f1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 14:59:53 -0600 Subject: [PATCH 60/62] Better inlining heuristic --- core/compiler/test/optimizer.factor | 11 ++++++++++- core/compiler/test/redefine.factor | 2 +- core/optimizer/backend/backend.factor | 22 ++++++++++++++++++---- 3 files changed, 29 insertions(+), 6 deletions(-) diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor index 091648cbbc..7ee4ebfd1c 100755 --- a/core/compiler/test/optimizer.factor +++ b/core/compiler/test/optimizer.factor @@ -2,7 +2,7 @@ USING: arrays compiler 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 ; +continuations growable ; IN: temporary [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ @@ -291,3 +291,12 @@ TUPLE: silly-tuple a b ; : construct-empty-bug construct-empty ; [ ] [ [ construct-empty ] dataflow optimize drop ] unit-test + +! Make sure we have sane heuristics +: should-inline? method method-word flat-length 10 <= ; + +[ t ] [ \ fixnum \ shift should-inline? ] unit-test +[ f ] [ \ array \ equal? should-inline? ] unit-test +[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test +[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index e9927f4964..ab472668c3 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -235,7 +235,7 @@ DEFER: flushable-test-2 : bx ax ; [ \ bx forget ] with-compilation-unit -[ f ] [ \ bx \ ax compiled-usage contains? ] unit-test +[ f ] [ \ bx \ ax compiled-usage key? ] unit-test DEFER: defer-redefine-test-2 diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index e73200b861..788f862849 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -245,18 +245,32 @@ M: #dispatch optimize-node* : dispatching-class ( node word -- class ) [ dispatch# node-class# ] keep specific-method ; -: flat-length ( seq -- n ) +! A heuristic to avoid excessive inlining +DEFER: (flat-length) + +: word-flat-length ( word -- n ) + dup get over inline? not or + [ drop 1 ] [ dup dup set word-def (flat-length) ] if ; + +: (flat-length) ( seq -- n ) [ - dup quotation? over array? or - [ flat-length ] [ drop 1 ] if + { + { [ dup quotation? ] [ (flat-length) 1+ ] } + { [ dup array? ] [ (flat-length) ] } + { [ dup word? ] [ word-flat-length ] } + { [ t ] [ drop 1 ] } + } cond ] map sum ; +: flat-length ( seq -- n ) + [ word-def (flat-length) ] with-scope ; + : will-inline-method ( node word -- method-spec/t quot/t ) #! t indicates failure tuck dispatching-class dup [ swap [ 2array ] 2keep method method-word - dup word-def flat-length 5 >= + dup flat-length 10 >= [ 1quotation ] [ word-def ] if ] [ 2drop t t From 8428f66933f1cfb9c20e818667b8ef36eb93b614 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 15:00:10 -0600 Subject: [PATCH 61/62] Fixing unit tests --- core/classes/classes-tests.factor | 6 ++++-- core/generic/generic-tests.factor | 2 +- core/inference/inference-tests.factor | 4 ++-- core/tuples/tuples-tests.factor | 2 +- core/vocabs/loader/loader-tests.factor | 17 +++++++---------- extra/combinators/lib/lib-tests.factor | 2 +- extra/tools/test/test.factor | 2 +- 7 files changed, 17 insertions(+), 18 deletions(-) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index d78436bd5f..c7024a7490 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -169,8 +169,10 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ; UNION: forget-class-bug-1 integer ; UNION: forget-class-bug-2 forget-class-bug-1 dll ; -FORGET: forget-class-bug-1 -FORGET: forget-class-bug-2 +[ + \ forget-class-bug-1 forget + \ forget-class-bug-2 forget +] with-compilation-unit [ f ] [ forget-class-bug-1 typemap get values [ memq? ] with contains? ] unit-test diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index e4d4160605..e3fdbc7b46 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -155,7 +155,7 @@ M: string my-hook "a string" ; [ "an integer" ] [ 3 my-var set my-hook ] unit-test [ "a string" ] [ my-hook my-var set my-hook ] unit-test -[ 1.0 my-var set my-hook ] [ [ T{ no-method f 1.0 my-hook } = ] must-fail-with +[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with GENERIC: tag-and-f ( x -- x x ) diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 1738a71b7e..b43226166a 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -326,10 +326,10 @@ DEFER: bar : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; [ [ bad-bin ] infer ] must-fail -[ [ [ r> ] infer ] [ inference-error? ] must-fail-with +[ [ r> ] infer ] [ inference-error? ] must-fail-with ! Regression -[ [ [ get-slots ] infer ] [ inference-error? ] must-fail-with +[ [ get-slots ] infer ] [ inference-error? ] must-fail-with ! Test some curry stuff { 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index dede1a2136..c9656a3b9e 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -123,7 +123,7 @@ TUPLE: yo-momma ; [ ] [ \ yo-momma forget ] unit-test [ f ] [ \ yo-momma typemap get values memq? ] unit-test - [ f ] [ \ yo-momma crossref ] unit-test + [ f ] [ \ yo-momma crossref get at ] unit-test ] with-compilation-unit TUPLE: loc-recording ; diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 764f14e45f..3a8fc37583 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -63,14 +63,12 @@ IN: temporary [ 2 ] [ "count-me" get-global ] unit-test -[ t ] [ - [ - "IN: vocabs.loader.test.a v-l-t-a-hello" - - "resource:core/vocabs/loader/test/a/a.factor" - parse-stream - ] catch [ no-word? ] is? -] unit-test +[ + "IN: vocabs.loader.test.a v-l-t-a-hello" + + "resource:core/vocabs/loader/test/a/a.factor" + parse-stream +] [ [ no-word? ] is? ] must-fail-with 0 "count-me" set-global @@ -121,8 +119,7 @@ IN: temporary [ "kernel" vocab where ] unit-test [ t ] [ - [ "vocabs.loader.test.d" require ] catch - [ :1 ] when + [ "vocabs.loader.test.d" require ] [ :1 ] recover "vocabs.loader.test.d" vocab-source-loaded? ] unit-test diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index 235f441b8b..20f52b2ea3 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -1,5 +1,5 @@ USING: combinators.lib kernel math math.ranges random sequences -tools.test inference continuations arrays vectors ; +tools.test tools.test.inference continuations arrays vectors ; IN: temporary [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 1037323ddb..9590f32539 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -37,7 +37,7 @@ M: expected-error summary : must-fail-with ( quot test -- ) >r [ expected-error construct-empty throw ] compose r> [ recover ] 2curry - [ ] swap unit-test ; + [ t ] swap unit-test ; : must-fail ( quot -- ) [ drop t ] must-fail-with ; From 90ed177a9c410eacdf6ddad3a09cf025bcae13fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 19:23:39 -0600 Subject: [PATCH 62/62] Fixing load-everything and unit tests --- core/dlists/dlists.factor | 5 +++++ core/io/files/files-tests.factor | 3 ++- core/io/files/files.factor | 8 ++++++-- core/parser/parser-tests.factor | 8 ++++++++ core/parser/parser.factor | 10 +++++++--- core/vocabs/loader/loader.factor | 7 ++++--- extra/asn1/asn1-tests.factor | 4 ++-- extra/concurrency/concurrency-tests.factor | 2 ++ extra/concurrency/concurrency.factor | 2 +- extra/hardware-info/windows/ce/ce.factor | 16 ++++++++-------- extra/http/server/templating/templating.factor | 7 ++++--- extra/ldap/libldap/libldap.factor | 8 ++++---- extra/math/constants/constants-docs.factor | 4 ++-- extra/math/constants/constants.factor | 2 +- .../math/matrices/elimination/elimination.factor | 7 +++++-- extra/nehe/5/5.factor | 4 +++- extra/openssl/libcrypto/libcrypto.factor | 2 +- extra/openssl/openssl-tests.factor | 2 +- extra/openssl/openssl.factor | 2 +- .../partial-continuations.factor | 4 ++-- extra/random-tester/random-tester.factor | 6 +++--- extra/regexp/regexp.factor | 2 +- extra/serialize/serialize-tests.factor | 4 +--- extra/state-parser/state-parser-tests.factor | 2 +- extra/tuple-syntax/tuple-syntax-tests.factor | 1 + extra/tuple-syntax/tuple-syntax.factor | 9 +++++---- extra/ui/gadgets/editors/editors.factor | 6 +++--- extra/xmode/utilities/utilities-tests.factor | 4 ++-- 28 files changed, 86 insertions(+), 55 deletions(-) mode change 100644 => 100755 extra/concurrency/concurrency-tests.factor mode change 100644 => 100755 extra/concurrency/concurrency.factor mode change 100644 => 100755 extra/ldap/libldap/libldap.factor mode change 100644 => 100755 extra/nehe/5/5.factor mode change 100644 => 100755 extra/openssl/libcrypto/libcrypto.factor mode change 100644 => 100755 extra/openssl/openssl-tests.factor mode change 100644 => 100755 extra/openssl/openssl.factor mode change 100644 => 100755 extra/partial-continuations/partial-continuations.factor mode change 100644 => 100755 extra/random-tester/random-tester.factor mode change 100644 => 100755 extra/serialize/serialize-tests.factor mode change 100644 => 100755 extra/state-parser/state-parser-tests.factor mode change 100644 => 100755 extra/tuple-syntax/tuple-syntax-tests.factor mode change 100644 => 100755 extra/tuple-syntax/tuple-syntax.factor mode change 100644 => 100755 extra/xmode/utilities/utilities-tests.factor diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index ddec312182..12b1cd51ad 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -144,6 +144,11 @@ PRIVATE> : dlist-delete ( obj dlist -- obj/f ) >r [ eq? ] curry r> delete-node-if ; +: dlist-delete-all ( dlist -- ) + f over set-dlist-front + f over set-dlist-back + 0 swap set-dlist-length ; + : dlist-each ( dlist quot -- ) [ dlist-node-obj ] swap compose dlist-each-node ; inline diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 5d4bb70912..bac9a2e65e 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -2,7 +2,8 @@ IN: temporary USING: tools.test io.files io threads kernel continuations ; [ "passwd" ] [ "/etc/passwd" file-name ] unit-test -[ "awk/" ] [ "/usr/libexec/awk/" file-name ] unit-test +[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test +[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test [ ] [ "test-foo.txt" resource-path [ diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 9a99090699..5d0cf6bf11 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -64,7 +64,7 @@ M: object root-directory? ( path -- ? ) path-separator? ; normalize-directory dup (directory) fixup-directory ; : last-path-separator ( path -- n ? ) - [ length 2 [-] ] keep [ path-separator? ] find-last* ; + [ length 1- ] keep [ path-separator? ] find-last* ; TUPLE: no-parent-directory path ; @@ -83,7 +83,11 @@ TUPLE: no-parent-directory path ; } cond ; : file-name ( path -- string ) - dup last-path-separator [ 1+ tail ] [ drop ] if ; + right-trim-separators { + { [ dup empty? ] [ drop "/" ] } + { [ dup last-path-separator ] [ 1+ tail ] } + { [ t ] [ drop ] } + } cond ; : resource-path ( path -- newpath ) \ resource-path get [ image parent-directory ] unless* diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index eb04e329d9..c40bc54335 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -349,6 +349,14 @@ IN: temporary "IN: temporary : foo ; TUPLE: foo ;" "redefining-a-class-4" parse-stream drop ] [ [ redefine-error? ] is? ] must-fail-with + + [ ] [ + "IN: temporary : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval + ] unit-test + + [ + "IN: temporary : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval + ] must-fail ] with-file-vocabs [ diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 59d18dc734..d54bf1c1f4 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -307,10 +307,14 @@ SYMBOL: lexer-factory ! Parsing word utilities : parse-effect ( -- effect ) - ")" parse-tokens { "--" } split1 dup [ - + ")" parse-tokens "(" over member? [ + "Stack effect declaration must not contain (" throw ] [ - "Stack effect declaration must contain --" throw + { "--" } split1 dup [ + + ] [ + "Stack effect declaration must contain --" throw + ] if ] if ; TUPLE: bad-number ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 64372fe4b7..e42dace945 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -149,12 +149,14 @@ SYMBOL: load-help? dup modified-sources swap modified-docs ; : load-error. ( vocab error -- ) - "While loading " rot dup >vocab-link write-object ":" print - print-error ; + "==== " write >r + dup vocab-name swap f >vocab-link write-object ":" print nl + r> print-error ; TUPLE: require-all-error vocabs ; : require-all-error ( vocabs -- ) + [ vocab-name ] map \ require-all-error construct-boa throw ; M: require-all-error summary @@ -167,7 +169,6 @@ M: require-all-error summary [ [ require ] [ 2array , ] recover ] each ] { } make dup empty? [ drop ] [ - "==== LOAD ERRORS:" print dup [ nl load-error. ] assoc-each keys require-all-error ] if diff --git a/extra/asn1/asn1-tests.factor b/extra/asn1/asn1-tests.factor index 1c9bc79d76..329ba8256d 100755 --- a/extra/asn1/asn1-tests.factor +++ b/extra/asn1/asn1-tests.factor @@ -5,11 +5,11 @@ USING: asn1 asn1.ldap io io.streams.string tools.test ; ] unit-test [ "testing" ] [ - "\u0004\u0007testing" [ asn-syntax read-ber ] with-stream + "\u000004\u000007testing" [ asn-syntax read-ber ] with-stream ] unit-test [ { 1 { 3 "Administrator" "ad_is_bogus" } } ] [ - "0$\u0002\u0001\u0001`\u001f\u0002\u0001\u0003\u0004\rAdministrator\u0080\u000bad_is_bogus" + "0$\u000002\u000001\u000001`\u00001f\u000002\u000001\u000003\u000004\rAdministrator\u000080\u00000bad_is_bogus" [ asn-syntax read-ber ] with-stream ] unit-test diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor old mode 100644 new mode 100755 index 2f9b6605d7..b6f62d1779 --- a/extra/concurrency/concurrency-tests.factor +++ b/extra/concurrency/concurrency-tests.factor @@ -6,6 +6,8 @@ namespaces tools.test continuations dlists strings math words match quotations concurrency.private ; IN: temporary +[ ] [ self process-mailbox mailbox-data dlist-delete-all ] unit-test + [ V{ 1 2 3 } ] [ 0 make-mailbox diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor old mode 100644 new mode 100755 index 8d842f15d0..cf44ab125c --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -73,7 +73,7 @@ PRIVATE> : mailbox-get?* ( pred mailbox timeout -- obj ) 2over >r >r (mailbox-block-unless-pred) r> r> - mailbox-data delete-node ; inline + mailbox-data delete-node-if ; inline : mailbox-get? ( pred mailbox -- obj ) f mailbox-get?* ; diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor index 8923d86b03..f671ea9426 100755 --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/hardware-info/windows/ce/ce.factor @@ -10,25 +10,25 @@ T{ wince-os } os set-global "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength [ GlobalMemoryStatus ] keep ; -M: wince cpus ( -- n ) 1 ; +M: wince-os cpus ( -- n ) 1 ; -M: wince memory-load ( -- n ) +M: wince-os memory-load ( -- n ) memory-status MEMORYSTATUS-dwMemoryLoad ; -M: wince physical-mem ( -- n ) +M: wince-os physical-mem ( -- n ) memory-status MEMORYSTATUS-dwTotalPhys ; -M: wince available-mem ( -- n ) +M: wince-os available-mem ( -- n ) memory-status MEMORYSTATUS-dwAvailPhys ; -M: wince total-page-file ( -- n ) +M: wince-os total-page-file ( -- n ) memory-status MEMORYSTATUS-dwTotalPageFile ; -M: wince available-page-file ( -- n ) +M: wince-os available-page-file ( -- n ) memory-status MEMORYSTATUS-dwAvailPageFile ; -M: wince total-virtual-mem ( -- n ) +M: wince-os total-virtual-mem ( -- n ) memory-status MEMORYSTATUS-dwTotalVirtual ; -M: wince available-virtual-mem ( -- n ) +M: wince-os available-virtual-mem ( -- n ) memory-status MEMORYSTATUS-dwAvailVirtual ; diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index f5de4664a1..dc83562600 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -32,17 +32,18 @@ M: template-lexer skip-word DEFER: <% delimiter : check-<% ( lexer -- col ) - "<%" over line-text rot lexer-column start* ; + "<%" over lexer-line-text rot lexer-column start* ; : found-<% ( accum lexer col -- accum ) [ - over line-text >r >r lexer-column r> r> subseq parsed + over lexer-line-text + >r >r lexer-column r> r> subseq parsed \ write-html parsed ] 2keep 2 + swap set-lexer-column ; : still-looking ( accum lexer -- accum ) [ - dup line-text swap lexer-column tail + dup lexer-line-text swap lexer-column tail parsed \ print-html parsed ] keep next-line ; diff --git a/extra/ldap/libldap/libldap.factor b/extra/ldap/libldap/libldap.factor old mode 100644 new mode 100755 index 6113fe5b7e..492aed1a54 --- a/extra/ldap/libldap/libldap.factor +++ b/extra/ldap/libldap/libldap.factor @@ -40,9 +40,9 @@ IN: ldap.libldap : LDAP_RES_UNSOLICITED 0 ; inline ! how many messages to retrieve results for -: LDAP_MSG_ONE HEX: 00 ; inline -: LDAP_MSG_ALL HEX: 01 ; inline -: LDAP_MSG_RECEIVED HEX: 02 ; inline +: LDAP_MSG_ONE HEX: 00 ; inline +: LDAP_MSG_ALL HEX: 01 ; inline +: LDAP_MSG_RECEIVED HEX: 02 ; inline ! the possible result types returned : LDAP_RES_BIND HEX: 61 ; inline @@ -71,7 +71,7 @@ IN: ldap.libldap { HEX: 79 "LDAP_RES_EXTENDED_PARTIAL" } } ; -: LDAP_OPT_PROTOCOL_VERSION HEX: 0011 ; inline +: LDAP_OPT_PROTOCOL_VERSION HEX: 0011 ; inline C-STRUCT: ldap { "char" "ld_lberoptions" } diff --git a/extra/math/constants/constants-docs.factor b/extra/math/constants/constants-docs.factor index 653444376a..42cdf0e8f1 100755 --- a/extra/math/constants/constants-docs.factor +++ b/extra/math/constants/constants-docs.factor @@ -4,7 +4,7 @@ IN: math.constants ARTICLE: "math-constants" "Constants" "Standard mathematical constants:" { $subsection e } -{ $subsection gamma } +{ $subsection euler } { $subsection phi } { $subsection pi } "Various limits:" @@ -17,7 +17,7 @@ ABOUT: "math-constants" HELP: e { $values { "e" "base of natural logarithm" } } ; -HELP: gamma +HELP: euler { $values { "gamma" "Euler-Mascheroni constant" } } { $description "The Euler-Mascheroni constant, also called \"Euler's constant\" or \"the Euler constant\"." } ; diff --git a/extra/math/constants/constants.factor b/extra/math/constants/constants.factor index c4abeca0eb..c207eaa63c 100755 --- a/extra/math/constants/constants.factor +++ b/extra/math/constants/constants.factor @@ -3,7 +3,7 @@ IN: math.constants : e ( -- e ) 2.7182818284590452354 ; inline -: gamma ( -- gamma ) 0.57721566490153286060 ; inline +: euler ( -- gamma ) 0.57721566490153286060 ; inline : phi ( -- phi ) 1.61803398874989484820 ; inline : pi ( -- pi ) 3.14159265358979323846 ; inline : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline diff --git a/extra/math/matrices/elimination/elimination.factor b/extra/math/matrices/elimination/elimination.factor index 73f6dd7e96..8ac9771767 100755 --- a/extra/math/matrices/elimination/elimination.factor +++ b/extra/math/matrices/elimination/elimination.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.vectors math.matrices namespaces -sequences parser ; +sequences ; IN: math.matrices.elimination SYMBOL: matrix @@ -20,6 +20,9 @@ SYMBOL: matrix : cols ( -- n ) 0 nth-row length ; +: skip ( i seq quot -- n ) + over >r find* drop r> length or ; inline + : first-col ( row# -- n ) #! First non-zero column 0 swap nth-row [ zero? not ] skip ; diff --git a/extra/nehe/5/5.factor b/extra/nehe/5/5.factor old mode 100644 new mode 100755 index a792f04479..31a7d059ae --- a/extra/nehe/5/5.factor +++ b/extra/nehe/5/5.factor @@ -108,10 +108,12 @@ M: nehe5-gadget draw-gadget* ( gadget -- ) : nehe5-update-thread ( gadget -- ) dup nehe5-gadget-quit? [ + drop + ] [ redraw-interval sleep dup relayout-1 nehe5-update-thread - ] unless ; + ] if ; M: nehe5-gadget graft* ( gadget -- ) [ f swap set-nehe5-gadget-quit? ] keep diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor old mode 100644 new mode 100755 index 52cb06f62e..8378a11956 --- a/extra/openssl/libcrypto/libcrypto.factor +++ b/extra/openssl/libcrypto/libcrypto.factor @@ -49,7 +49,7 @@ C-STRUCT: bio : BIO_CLOSE HEX: 01 ; inline : RSA_3 HEX: 3 ; inline -: RSA_F4 HEX: 10001 ; inline +: RSA_F4 HEX: 10001 ; inline : BIO_C_SET_SSL 109 ; inline : BIO_C_GET_SSL 110 ; inline diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor old mode 100644 new mode 100755 index f4576dca19..c40bc5628b --- a/extra/openssl/openssl-tests.factor +++ b/extra/openssl/openssl-tests.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types assocs bit-arrays hashtables io io.files io.sockets kernel mirrors openssl.libcrypto openssl.libssl -namespaces math math.parser openssl prettyprint sequences tools.test unix ; +namespaces math math.parser openssl prettyprint sequences tools.test ; ! ========================================================= ! Some crypto functions (still to be turned into words) diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor old mode 100644 new mode 100755 index 3b5474ea9f..bfa7f32594 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -4,7 +4,7 @@ ! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC USING: alien alien.c-types assocs kernel libc namespaces -openssl.libcrypto openssl.libssl sequences unix ; +openssl.libcrypto openssl.libssl sequences ; IN: openssl diff --git a/extra/partial-continuations/partial-continuations.factor b/extra/partial-continuations/partial-continuations.factor old mode 100644 new mode 100755 index 0dce7c2390..b80e3a9ddb --- a/extra/partial-continuations/partial-continuations.factor +++ b/extra/partial-continuations/partial-continuations.factor @@ -6,7 +6,7 @@ USING: kernel continuations arrays sequences quotations ; : breset ( quot -- ) [ 1array swap keep first continue-with ] callcc1 nip ; -: (bshift) ( v r k -- ) +: (bshift) ( v r k -- obj ) >r dup first -rot r> [ rot set-first @@ -19,4 +19,4 @@ USING: kernel continuations arrays sequences quotations ; over >r [ (bshift) ] 2curry swap call r> first continue-with - ] callcc1 2nip ; + ] callcc1 2nip ; inline diff --git a/extra/random-tester/random-tester.factor b/extra/random-tester/random-tester.factor old mode 100644 new mode 100755 index c3a1ecbec4..8704687e34 --- a/extra/random-tester/random-tester.factor +++ b/extra/random-tester/random-tester.factor @@ -17,9 +17,9 @@ TUPLE: random-tester-error ; : test-compiler ! ( data... quot -- ... ) errored off dup quot set - datastack clone >vector dup pop* before set - [ call ] catch drop - datastack clone after set + datastack 1 head* before set + [ call ] [ drop ] recover + datastack after set clear before get [ ] each quot get [ compile-call ] [ errored on ] recover ; diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index ef88e84f05..fe1d87d9e9 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -77,7 +77,7 @@ PRIVATE> : 'hex' ( -- parser ) "x" token 'hex-digit' 2 exactly-n &> - "u" token 'hex-digit' 4 exactly-n &> <|> + "u" token 'hex-digit' 6 exactly-n &> <|> [ hex> ] <@ ; : satisfy-tokens ( assoc -- parser ) diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor old mode 100644 new mode 100755 index a713840a20..e0ecb5393a --- a/extra/serialize/serialize-tests.factor +++ b/extra/serialize/serialize-tests.factor @@ -10,8 +10,6 @@ TUPLE: serialize-test a b ; C: serialize-test -: CURRY< \ > parse-until first2 curry parsed ; parsing - : objects { f @@ -33,7 +31,7 @@ C: serialize-test B{ 50 13 55 64 1 } ?{ t f t f f t f } F{ 1.0 3.0 4.0 1.0 2.35 0.33 } - CURRY< 1 [ 2 ] > + << 1 [ 2 ] curry parsed >> { { "a" "bc" } { "de" "fg" } } H{ { "a" "bc" } { "de" "fg" } } } ; diff --git a/extra/state-parser/state-parser-tests.factor b/extra/state-parser/state-parser-tests.factor old mode 100644 new mode 100755 index ff8ac91513..4e1ecaddfc --- a/extra/state-parser/state-parser-tests.factor +++ b/extra/state-parser/state-parser-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test state-parser kernel io strings ; +USING: tools.test state-parser kernel io strings ascii ; [ "hello" ] [ "hello" [ rest ] string-parse ] unit-test [ 2 4 ] [ "12\n123" [ rest drop get-line get-column ] string-parse ] unit-test diff --git a/extra/tuple-syntax/tuple-syntax-tests.factor b/extra/tuple-syntax/tuple-syntax-tests.factor old mode 100644 new mode 100755 index b16c5b337d..0a9711c446 --- a/extra/tuple-syntax/tuple-syntax-tests.factor +++ b/extra/tuple-syntax/tuple-syntax-tests.factor @@ -1,4 +1,5 @@ USING: tools.test tuple-syntax ; +IN: temporary TUPLE: foo bar baz ; diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor old mode 100644 new mode 100755 index 6082f529ac..2f0ba6bde5 --- a/extra/tuple-syntax/tuple-syntax.factor +++ b/extra/tuple-syntax/tuple-syntax.factor @@ -1,4 +1,5 @@ -USING: kernel sequences slots parser words classes ; +USING: kernel sequences slots parser words classes +slots.private ; IN: tuple-syntax ! TUPLE: foo bar baz ; @@ -7,15 +8,15 @@ IN: tuple-syntax : parse-object ( -- object ) scan-word dup parsing? [ V{ } clone swap execute first ] when ; -: parse-slot-writer ( tuple -- slot-setter ) +: parse-slot-writer ( tuple -- slot# ) scan dup "}" = [ 2drop f ] [ 1 head* swap class "slots" word-prop - [ slot-spec-name = ] with find nip slot-spec-writer + [ slot-spec-name = ] with find nip slot-spec-offset ] if ; : parse-slots ( accum tuple -- accum tuple ) dup parse-slot-writer - [ parse-object pick rot execute parse-slots ] when* ; + [ parse-object pick rot set-slot parse-slots ] when* ; : TUPLE{ scan-word construct-empty parse-slots parsed ; parsing diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index 00b574f853..e2df6a343b 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -249,11 +249,11 @@ M: editor gadget-text* editor-string % ; : extend-selection ( editor -- ) dup request-focus dup editor-caret click-loc ; -: mouse-elt ( -- elelement ) +: mouse-elt ( -- element ) hand-click# get { + { 1 T{ one-char-elt } } { 2 T{ one-word-elt } } - { 3 T{ one-line-elt } } - } at T{ one-char-elt } or ; + } at T{ one-line-elt } or ; : drag-direction? ( loc editor -- ? ) editor-mark* <=> 0 < ; diff --git a/extra/xmode/utilities/utilities-tests.factor b/extra/xmode/utilities/utilities-tests.factor old mode 100644 new mode 100755 index 89cb588336..713700bf7a --- a/extra/xmode/utilities/utilities-tests.factor +++ b/extra/xmode/utilities/utilities-tests.factor @@ -1,6 +1,6 @@ IN: temporary -USING: xmode.utilities tools.test xml xml.data -kernel strings vectors sequences io.files prettyprint assocs ; +USING: xmode.utilities tools.test xml xml.data kernel strings +vectors sequences io.files prettyprint assocs unicode.case ; [ "hi" 3 ] [ { 1 2 3 4 5 6 7 8 } [ H{ { 3 "hi" } } at ] map-find