From ee30ab92cd14bfd7e134c25afbbd120ea6f57bb8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 11 Apr 2009 13:02:47 -0500 Subject: [PATCH 01/98] redoing db framework. it'll live in extra until it can replace db in basis --- extra/db2/authors.txt | 1 + extra/db2/connections/authors.txt | 1 + extra/db2/connections/connections.factor | 17 +++++++++ extra/db2/db2.factor | 20 +++++++++++ extra/db2/result-sets/authors.txt | 1 + extra/db2/result-sets/result-sets.factor | 29 ++++++++++++++++ extra/db2/statements/authors.txt | 1 + extra/db2/statements/statements.factor | 40 ++++++++++++++++++++++ extra/db2/transactions/authors.txt | 1 + extra/db2/transactions/transactions.factor | 23 +++++++++++++ 10 files changed, 134 insertions(+) create mode 100644 extra/db2/authors.txt create mode 100644 extra/db2/connections/authors.txt create mode 100644 extra/db2/connections/connections.factor create mode 100644 extra/db2/db2.factor create mode 100644 extra/db2/result-sets/authors.txt create mode 100644 extra/db2/result-sets/result-sets.factor create mode 100644 extra/db2/statements/authors.txt create mode 100644 extra/db2/statements/statements.factor create mode 100644 extra/db2/transactions/authors.txt create mode 100644 extra/db2/transactions/transactions.factor diff --git a/extra/db2/authors.txt b/extra/db2/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/db2/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/db2/connections/authors.txt b/extra/db2/connections/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/db2/connections/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/db2/connections/connections.factor b/extra/db2/connections/connections.factor new file mode 100644 index 0000000000..c622f9a4b4 --- /dev/null +++ b/extra/db2/connections/connections.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors destructors fry kernel namespaces ; +IN: db2.connections + +TUPLE: db-connection handle ; + +GENERIC: db-open ( db -- db-connection ) +HOOK: db-close db-connection ( handle -- ) +HOOK: parse-db-error db-connection ( error -- error' ) + +M: db-connection dispose ( db-connection -- ) + [ db-close f ] change-handle drop ; + +: with-db ( db quot -- ) + [ db-open db-connection dup ] dip + '[ _ [ drop @ ] with-disposal ] with-variable ; inline diff --git a/extra/db2/db2.factor b/extra/db2/db2.factor new file mode 100644 index 0000000000..16afbd2782 --- /dev/null +++ b/extra/db2/db2.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors continuations destructors fry kernel +namespaces sequences strings db2.statements ; +IN: db2 + + [ execute-statement ] with-disposal ; + +PRIVATE> + +: sql-command ( sql -- ) + dup string? + [ execute-sql-string ] + [ [ execute-sql-string ] each ] if ; + +: sql-query ( sql -- sequence ) + f f [ statement>result-sequence ] with-disposal ; diff --git a/extra/db2/result-sets/authors.txt b/extra/db2/result-sets/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/db2/result-sets/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/db2/result-sets/result-sets.factor b/extra/db2/result-sets/result-sets.factor new file mode 100644 index 0000000000..0f242da473 --- /dev/null +++ b/extra/db2/result-sets/result-sets.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel sequences ; +IN: db2.result-sets + +TUPLE: result-set sql in out handle n max ; + +GENERIC: #rows ( result-set -- n ) +GENERIC: #columns ( result-set -- n ) +GENERIC: advance-row ( result-set -- ) +GENERIC: more-rows? ( result-set -- ? ) +GENERIC# column 1 ( result-set column -- obj ) +GENERIC# column-typed 1 ( result-set column -- sql ) + +: init-result-set ( result-set -- result-set ) + dup #rows >>max + 0 >>n ; + +: new-result-set ( query handle class -- result-set ) + new + swap >>handle + swap [ sql>> >>sql ] [ in>> >>in ] [ out>> >>out ] tri ; + +: sql-row ( result-set -- seq ) + dup #columns [ column ] with map ; + +: sql-row-typed ( result-set -- seq ) + dup #columns [ column-typed ] with map ; + diff --git a/extra/db2/statements/authors.txt b/extra/db2/statements/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/db2/statements/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/db2/statements/statements.factor b/extra/db2/statements/statements.factor new file mode 100644 index 0000000000..282fb7d5bf --- /dev/null +++ b/extra/db2/statements/statements.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors continuations destructors fry kernel +sequences db2.result-sets db2.connections ; +IN: db2.statements + +TUPLE: statement handle sql in out ; + +: new-statement ( sql in out class -- statement ) + new + swap >>out + swap >>in + swap >>sql ; + +HOOK: db-connection ( sql in out -- statement ) +GENERIC: execute-statement* ( statement type -- ) +GENERIC: statement>result-set ( statement -- result-set ) + +M: object execute-statement* ( statement type -- ) + drop '[ _ statement>result-set dispose ] + [ parse-db-error rethrow ] recover ; + +: execute-one-statement ( statement -- ) + dup type>> execute-statement* ; + +: execute-statement ( statement -- ) + dup sequence? + [ [ execute-one-statement ] each ] + [ execute-one-statement ] if ; + +: statement-each ( statement quot: ( statement -- ) -- ) + over more-rows? + [ [ call ] 2keep over advance-row statement-each ] + [ 2drop ] if ; inline recursive + +: statement-map ( statement quot -- sequence ) + accumulator [ statement-each ] dip { } like ; inline + +: statement>result-sequence ( statement -- sequence ) + statement>result-set [ [ sql-row ] statement-map ] with-disposal ; diff --git a/extra/db2/transactions/authors.txt b/extra/db2/transactions/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/db2/transactions/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/db2/transactions/transactions.factor b/extra/db2/transactions/transactions.factor new file mode 100644 index 0000000000..081c8dbe57 --- /dev/null +++ b/extra/db2/transactions/transactions.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: db2 ; +IN: db2.transactions + +! Transactions +SYMBOL: in-transaction + +HOOK: begin-transaction db-connection ( -- ) +HOOK: commit-transaction db-connection ( -- ) +HOOK: rollback-transaction db-connection ( -- ) + +M: db-connection begin-transaction ( -- ) "BEGIN" sql-command ; +M: db-connection commit-transaction ( -- ) "COMMIT" sql-command ; +M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ; + +: in-transaction? ( -- ? ) in-transaction get ; + +: with-transaction ( quot -- ) + t in-transaction [ + begin-transaction + [ ] [ rollback-transaction ] cleanup commit-transaction + ] with-variable ; inline From 72205363fdff7b8dcdb8cfda0f24a4b9c208990f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 11 Apr 2009 13:44:06 -0500 Subject: [PATCH 02/98] porting more things over to extra/db2 --- extra/db2/errors/errors.factor | 40 +++++ extra/db2/errors/postgresql/authors.txt | 1 + .../errors/postgresql/postgresql-tests.factor | 32 ++++ extra/db2/errors/postgresql/postgresql.factor | 53 +++++++ extra/db2/errors/sqlite/authors.txt | 1 + extra/db2/errors/sqlite/sqlite-tests.factor | 26 ++++ extra/db2/errors/sqlite/sqlite.factor | 28 ++++ extra/db2/errors/summary.txt | 1 + extra/db2/pools/authors.txt | 1 + extra/db2/pools/pools-tests.factor | 22 +++ extra/db2/pools/pools.factor | 20 +++ extra/db2/result-sets/result-sets.factor | 1 - extra/db2/sqlite/authors.txt | 1 + extra/db2/sqlite/ffi/ffi.factor | 142 ++++++++++++++++++ extra/db2/sqlite/lib/lib.factor | 119 +++++++++++++++ extra/db2/sqlite/sqlite.factor | 4 + extra/db2/sqlite/types/authors.txt | 1 + extra/db2/sqlite/types/types.factor | 62 ++++++++ extra/db2/transactions/transactions.factor | 3 +- extra/db2/types/authors.txt | 1 + extra/db2/types/types.factor | 17 +++ 21 files changed, 573 insertions(+), 3 deletions(-) create mode 100644 extra/db2/errors/errors.factor create mode 100644 extra/db2/errors/postgresql/authors.txt create mode 100644 extra/db2/errors/postgresql/postgresql-tests.factor create mode 100644 extra/db2/errors/postgresql/postgresql.factor create mode 100644 extra/db2/errors/sqlite/authors.txt create mode 100644 extra/db2/errors/sqlite/sqlite-tests.factor create mode 100644 extra/db2/errors/sqlite/sqlite.factor create mode 100644 extra/db2/errors/summary.txt create mode 100644 extra/db2/pools/authors.txt create mode 100644 extra/db2/pools/pools-tests.factor create mode 100644 extra/db2/pools/pools.factor create mode 100644 extra/db2/sqlite/authors.txt create mode 100644 extra/db2/sqlite/ffi/ffi.factor create mode 100644 extra/db2/sqlite/lib/lib.factor create mode 100644 extra/db2/sqlite/sqlite.factor create mode 100644 extra/db2/sqlite/types/authors.txt create mode 100644 extra/db2/sqlite/types/types.factor create mode 100644 extra/db2/types/authors.txt create mode 100644 extra/db2/types/types.factor diff --git a/extra/db2/errors/errors.factor b/extra/db2/errors/errors.factor new file mode 100644 index 0000000000..bd330e6191 --- /dev/null +++ b/extra/db2/errors/errors.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel continuations fry words constructors ; +IN: db2.errors + +ERROR: db-error ; +ERROR: sql-error location ; + +ERROR: sql-unknown-error < sql-error message ; +CONSTRUCTOR: sql-unknown-error ( message -- error ) ; + +ERROR: sql-table-exists < sql-error table ; +CONSTRUCTOR: sql-table-exists ( table -- error ) ; + +ERROR: sql-table-missing < sql-error table ; +CONSTRUCTOR: sql-table-missing ( table -- error ) ; + +ERROR: sql-syntax-error < sql-error message ; +CONSTRUCTOR: sql-syntax-error ( message -- error ) ; + +ERROR: sql-function-exists < sql-error message ; +CONSTRUCTOR: sql-function-exists ( message -- error ) ; + +ERROR: sql-function-missing < sql-error message ; +CONSTRUCTOR: sql-function-missing ( message -- error ) ; + +: ignore-error ( quot word -- ) + '[ dup _ execute [ drop ] [ rethrow ] if ] recover ; inline + +: ignore-table-exists ( quot -- ) + \ sql-table-exists? ignore-error ; inline + +: ignore-table-missing ( quot -- ) + \ sql-table-missing? ignore-error ; inline + +: ignore-function-exists ( quot -- ) + \ sql-function-exists? ignore-error ; inline + +: ignore-function-missing ( quot -- ) + \ sql-function-missing? ignore-error ; inline diff --git a/extra/db2/errors/postgresql/authors.txt b/extra/db2/errors/postgresql/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/db2/errors/postgresql/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/db2/errors/postgresql/postgresql-tests.factor b/extra/db2/errors/postgresql/postgresql-tests.factor new file mode 100644 index 0000000000..f6668031e5 --- /dev/null +++ b/extra/db2/errors/postgresql/postgresql-tests.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators.short-circuit db db.errors +db.errors.postgresql db.postgresql io.files.unique kernel namespaces +tools.test db.tester continuations ; +IN: db.errors.postgresql.tests + +[ + + [ "drop table foo;" sql-command ] ignore-errors + [ "drop table ship;" sql-command ] ignore-errors + + [ + "insert into foo (id) values('1');" sql-command + ] [ + { [ sql-table-missing? ] [ table>> "foo" = ] } 1&& + ] must-fail-with + + [ + "create table ship(id integer);" sql-command + "create table ship(id integer);" sql-command + ] [ + { [ sql-table-exists? ] [ table>> "ship" = ] } 1&& + ] must-fail-with + + [ + "create table foo(id) lol;" sql-command + ] [ + sql-syntax-error? + ] must-fail-with + +] test-postgresql diff --git a/extra/db2/errors/postgresql/postgresql.factor b/extra/db2/errors/postgresql/postgresql.factor new file mode 100644 index 0000000000..02b43ecd88 --- /dev/null +++ b/extra/db2/errors/postgresql/postgresql.factor @@ -0,0 +1,53 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel db.errors peg.ebnf strings sequences math +combinators.short-circuit accessors math.parser quoting ; +IN: db.errors.postgresql + +EBNF: parse-postgresql-sql-error + +Error = "ERROR:" [ ]+ + +TableError = + Error ("relation "|"table ")(!(" already exists").)+:table " already exists" + => [[ table >string unquote ]] + | Error ("relation "|"table ")(!(" does not exist").)+:table " does not exist" + => [[ table >string unquote ]] + +FunctionError = + Error "function" (!(" already exists").)+:table " already exists" + => [[ table >string ]] + | Error "function" (!(" does not exist").)+:table " does not exist" + => [[ table >string ]] + +SyntaxError = + Error "syntax error at end of input":error + => [[ error >string ]] + | Error "syntax error at or near " .+:syntaxerror + => [[ syntaxerror >string unquote ]] + +UnknownError = .* => [[ >string ]] + +PostgresqlSqlError = (TableError | FunctionError | SyntaxError | UnknownError) + +;EBNF + + +ERROR: parse-postgresql-location column line text ; +C: parse-postgresql-location + +EBNF: parse-postgresql-line-error + +Line = "LINE " [0-9]+:line ": " .+:sql + => [[ f line >string string>number sql >string ]] + +;EBNF + +:: set-caret-position ( error caret-line -- error ) + caret-line length + error line>> number>string length "LINE : " length + + - [ error ] dip >>column ; + +: postgresql-location ( line column -- obj ) + [ parse-postgresql-line-error ] dip + set-caret-position ; diff --git a/extra/db2/errors/sqlite/authors.txt b/extra/db2/errors/sqlite/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/db2/errors/sqlite/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/db2/errors/sqlite/sqlite-tests.factor b/extra/db2/errors/sqlite/sqlite-tests.factor new file mode 100644 index 0000000000..68ae55f8a8 --- /dev/null +++ b/extra/db2/errors/sqlite/sqlite-tests.factor @@ -0,0 +1,26 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators.short-circuit db db.errors +db.errors.sqlite db.sqlite io.files.unique kernel namespaces +tools.test ; +IN: db.errors.sqlite.tests + +: sqlite-error-test-db-path ( -- path ) + "sqlite" "error-test" make-unique-file ; + +sqlite-error-test-db-path [ + + [ + "insert into foo (id) values('1');" sql-command + ] [ + { [ sql-table-missing? ] [ table>> "foo" = ] } 1&& + ] must-fail-with + + [ + "create table foo(id);" sql-command + "create table foo(id);" sql-command + ] [ + { [ sql-table-exists? ] [ table>> "foo" = ] } 1&& + ] must-fail-with + +] with-db \ No newline at end of file diff --git a/extra/db2/errors/sqlite/sqlite.factor b/extra/db2/errors/sqlite/sqlite.factor new file mode 100644 index 0000000000..c73409b850 --- /dev/null +++ b/extra/db2/errors/sqlite/sqlite.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators db kernel sequences peg.ebnf +strings db.errors ; +IN: db.errors.sqlite + +TUPLE: unparsed-sqlite-error error ; +C: unparsed-sqlite-error + +SINGLETONS: table-exists table-missing ; + +: sqlite-table-error ( table message -- error ) + { + { table-exists [ ] } + } case ; + +EBNF: parse-sqlite-sql-error + +TableMessage = " already exists" => [[ table-exists ]] + +SqliteError = + "table " (!(TableMessage).)+:table TableMessage:message + => [[ table >string message sqlite-table-error ]] + | "no such table: " .+:table + => [[ table >string ]] + | .*:error + => [[ error >string ]] +;EBNF diff --git a/extra/db2/errors/summary.txt b/extra/db2/errors/summary.txt new file mode 100644 index 0000000000..1cd102173f --- /dev/null +++ b/extra/db2/errors/summary.txt @@ -0,0 +1 @@ +Errors thrown by database library diff --git a/extra/db2/pools/authors.txt b/extra/db2/pools/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/db2/pools/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/db2/pools/pools-tests.factor b/extra/db2/pools/pools-tests.factor new file mode 100644 index 0000000000..7ff2a33d92 --- /dev/null +++ b/extra/db2/pools/pools-tests.factor @@ -0,0 +1,22 @@ +IN: db.pools.tests +USING: db.pools tools.test continuations io.files io.files.temp +io.directories namespaces accessors kernel math destructors ; + +\ must-infer + +{ 1 0 } [ [ ] with-db-pool ] must-infer-as + +{ 1 0 } [ [ ] with-pooled-db ] must-infer-as + +! Test behavior after image save/load +USE: db.sqlite + +[ "pool-test.db" temp-file delete-file ] ignore-errors + +[ ] [ "pool-test.db" temp-file "pool" set ] unit-test + +[ ] [ "pool" get expired>> t >>expired drop ] unit-test + +[ ] [ 1000 [ "pool" get [ ] with-pooled-db ] times ] unit-test + +[ ] [ "pool" get dispose ] unit-test diff --git a/extra/db2/pools/pools.factor b/extra/db2/pools/pools.factor new file mode 100644 index 0000000000..b22dbde398 --- /dev/null +++ b/extra/db2/pools/pools.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors db2.connections fry io.pools kernel +namespaces ; +IN: db.pools + +TUPLE: db-pool < pool db ; + +: ( db -- pool ) + db-pool + swap >>db ; + +: with-db-pool ( db quot -- ) + [ ] dip with-pool ; inline + +M: db-pool make-connection ( pool -- ) + db>> db-open ; + +: with-pooled-db ( pool quot -- ) + '[ db-connection _ with-variable ] with-pooled-connection ; inline diff --git a/extra/db2/result-sets/result-sets.factor b/extra/db2/result-sets/result-sets.factor index 0f242da473..8e35dc3862 100644 --- a/extra/db2/result-sets/result-sets.factor +++ b/extra/db2/result-sets/result-sets.factor @@ -26,4 +26,3 @@ GENERIC# column-typed 1 ( result-set column -- sql ) : sql-row-typed ( result-set -- seq ) dup #columns [ column-typed ] with map ; - diff --git a/extra/db2/sqlite/authors.txt b/extra/db2/sqlite/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/db2/sqlite/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/db2/sqlite/ffi/ffi.factor b/extra/db2/sqlite/ffi/ffi.factor new file mode 100644 index 0000000000..2594978ddf --- /dev/null +++ b/extra/db2/sqlite/ffi/ffi.factor @@ -0,0 +1,142 @@ +! Copyright (C) 2005 Chris Double, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +! Not all functions have been wrapped. +USING: alien alien.libraries alien.syntax combinators system ; +IN: db2.sqlite.ffi + +<< "sqlite" { + { [ os winnt? ] [ "sqlite3.dll" ] } + { [ os macosx? ] [ "/usr/lib/libsqlite3.dylib" ] } + { [ os unix? ] [ "libsqlite3.so" ] } + } cond "cdecl" add-library >> + +LIBRARY: sqlite + +! Return values from sqlite functions +CONSTANT: SQLITE_OK 0 ! Successful result +CONSTANT: SQLITE_ERROR 1 ! SQL error or missing database +CONSTANT: SQLITE_INTERNAL 2 ! An internal logic error in SQLite +CONSTANT: SQLITE_PERM 3 ! Access permission denied +CONSTANT: SQLITE_ABORT 4 ! Callback routine requested an abort +CONSTANT: SQLITE_BUSY 5 ! The database file is locked +CONSTANT: SQLITE_LOCKED 6 ! A table in the database is locked +CONSTANT: SQLITE_NOMEM 7 ! A malloc() failed +CONSTANT: SQLITE_READONLY 8 ! Attempt to write a readonly database +CONSTANT: SQLITE_INTERRUPT 9 ! Operation terminated by sqlite_interrupt() +CONSTANT: SQLITE_IOERR 10 ! Some kind of disk I/O error occurred +CONSTANT: SQLITE_CORRUPT 11 ! The database disk image is malformed +CONSTANT: SQLITE_NOTFOUND 12 ! (Internal Only) Table or record not found +CONSTANT: SQLITE_FULL 13 ! Insertion failed because database is full +CONSTANT: SQLITE_CANTOPEN 14 ! Unable to open the database file +CONSTANT: SQLITE_PROTOCOL 15 ! Database lock protocol error +CONSTANT: SQLITE_EMPTY 16 ! (Internal Only) Database table is empty +CONSTANT: SQLITE_SCHEMA 17 ! The database schema changed +CONSTANT: SQLITE_TOOBIG 18 ! Too much data for one row of a table +CONSTANT: SQLITE_CONSTRAINT 19 ! Abort due to contraint violation +CONSTANT: SQLITE_MISMATCH 20 ! Data type mismatch +CONSTANT: SQLITE_MISUSE 21 ! Library used incorrectly +CONSTANT: SQLITE_NOLFS 22 ! Uses OS features not supported on host +CONSTANT: SQLITE_AUTH 23 ! Authorization denied +CONSTANT: SQLITE_FORMAT 24 ! Auxiliary database format error +CONSTANT: SQLITE_RANGE 25 ! 2nd parameter to sqlite3_bind out of range +CONSTANT: SQLITE_NOTADB 26 ! File opened that is not a database file + +CONSTANT: sqlite-error-messages +{ + "Successful result" + "SQL error or missing database" + "An internal logic error in SQLite" + "Access permission denied" + "Callback routine requested an abort" + "The database file is locked" + "A table in the database is locked" + "A malloc() failed" + "Attempt to write a readonly database" + "Operation terminated by sqlite_interrupt()" + "Some kind of disk I/O error occurred" + "The database disk image is malformed" + "(Internal Only) Table or record not found" + "Insertion failed because database is full" + "Unable to open the database file" + "Database lock protocol error" + "(Internal Only) Database table is empty" + "The database schema changed" + "Too much data for one row of a table" + "Abort due to contraint violation" + "Data type mismatch" + "Library used incorrectly" + "Uses OS features not supported on host" + "Authorization denied" + "Auxiliary database format error" + "2nd parameter to sqlite3_bind out of range" + "File opened that is not a database file" +} + +! Return values from sqlite3_step +CONSTANT: SQLITE_ROW 100 +CONSTANT: SQLITE_DONE 101 + +! Return values from the sqlite3_column_type function +CONSTANT: SQLITE_INTEGER 1 +CONSTANT: SQLITE_FLOAT 2 +CONSTANT: SQLITE_TEXT 3 +CONSTANT: SQLITE_BLOB 4 +CONSTANT: SQLITE_NULL 5 + +! Values for the 'destructor' parameter of the 'bind' routines. +CONSTANT: SQLITE_STATIC 0 +CONSTANT: SQLITE_TRANSIENT -1 + +CONSTANT: SQLITE_OPEN_READONLY HEX: 00000001 +CONSTANT: SQLITE_OPEN_READWRITE HEX: 00000002 +CONSTANT: SQLITE_OPEN_CREATE HEX: 00000004 +CONSTANT: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008 +CONSTANT: SQLITE_OPEN_EXCLUSIVE HEX: 00000010 +CONSTANT: SQLITE_OPEN_MAIN_DB HEX: 00000100 +CONSTANT: SQLITE_OPEN_TEMP_DB HEX: 00000200 +CONSTANT: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400 +CONSTANT: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800 +CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 +CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 +CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 + +TYPEDEF: void sqlite3 +TYPEDEF: void sqlite3_stmt +TYPEDEF: longlong sqlite3_int64 +TYPEDEF: ulonglong sqlite3_uint64 + +FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ; +FUNCTION: int sqlite3_close ( sqlite3* pDb ) ; +FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ; +FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ; +FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ; +FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ; +FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; +FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ; +FUNCTION: sqlite3_uint64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; +FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ; +FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ; +FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; +FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ; +! Bind the same function as above, but for unsigned 64bit integers +: sqlite3-bind-uint64 ( pStmt index in64 -- int ) + "int" "sqlite" "sqlite3_bind_int64" + { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ; +FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ; +FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ; +FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ; +FUNCTION: int sqlite3_clear_bindings ( sqlite3_stmt* pStmt ) ; +FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ; +FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ; +FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ; +FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ; +FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ; +FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ; +! Bind the same function as above, but for unsigned 64bit integers +: sqlite3-column-uint64 ( pStmt col -- uint64 ) + "sqlite3_uint64" "sqlite" "sqlite3_column_int64" + { "sqlite3_stmt*" "int" } alien-invoke ; +FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ; +FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ; +FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ; +FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ; diff --git a/extra/db2/sqlite/lib/lib.factor b/extra/db2/sqlite/lib/lib.factor new file mode 100644 index 0000000000..2fe6d9cbdf --- /dev/null +++ b/extra/db2/sqlite/lib/lib.factor @@ -0,0 +1,119 @@ +! Copyright (C) 2008 Chris Double, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types arrays calendar.format +combinators db2.connections db2.sqlite.ffi db2.errors +io.backend io.encodings.string io.encodings.utf8 kernel math +namespaces present sequences serialize urls ; +IN: db2.sqlite.lib + +: ?when ( object quot -- object' ) dupd when ; inline + +ERROR: sqlite-error < db-error n string ; +ERROR: sqlite-sql-error < sql-error n string ; + +: throw-sqlite-error ( n -- * ) + dup sqlite-error-messages nth sqlite-error ; + +: sqlite-statement-error ( -- * ) + SQLITE_ERROR + db-connection get handle>> sqlite3_errmsg sqlite-sql-error ; + +: sqlite-check-result ( n -- ) + { + { SQLITE_OK [ ] } + { SQLITE_ERROR [ sqlite-statement-error ] } + [ throw-sqlite-error ] + } case ; + +: sqlite-open ( path -- db ) + normalize-path + "void*" + [ sqlite3_open sqlite-check-result ] keep *void* ; + +: sqlite-close ( db -- ) + sqlite3_close sqlite-check-result ; + +: sqlite-prepare ( db sql -- handle ) + utf8 encode dup length "void*" "void*" + [ sqlite3_prepare_v2 sqlite-check-result ] 2keep + drop *void* ; + +: sqlite-bind-parameter-index ( handle name -- index ) + sqlite3_bind_parameter_index ; + +: parameter-index ( handle name text -- handle name text ) + [ dupd sqlite-bind-parameter-index ] dip ; + +: sqlite-bind-text ( handle index text -- ) + utf8 encode dup length SQLITE_TRANSIENT + sqlite3_bind_text sqlite-check-result ; + +: sqlite-bind-int ( handle i n -- ) + sqlite3_bind_int sqlite-check-result ; + +: sqlite-bind-int64 ( handle i n -- ) + sqlite3_bind_int64 sqlite-check-result ; + +: sqlite-bind-uint64 ( handle i n -- ) + sqlite3-bind-uint64 sqlite-check-result ; + +: sqlite-bind-double ( handle i x -- ) + sqlite3_bind_double sqlite-check-result ; + +: sqlite-bind-null ( handle i -- ) + sqlite3_bind_null sqlite-check-result ; + +: sqlite-bind-blob ( handle i byte-array -- ) + dup length SQLITE_TRANSIENT + sqlite3_bind_blob sqlite-check-result ; + +: sqlite-bind-text-by-name ( handle name text -- ) + parameter-index sqlite-bind-text ; + +: sqlite-bind-int-by-name ( handle name int -- ) + parameter-index sqlite-bind-int ; + +: sqlite-bind-int64-by-name ( handle name int64 -- ) + parameter-index sqlite-bind-int64 ; + +: sqlite-bind-uint64-by-name ( handle name int64 -- ) + parameter-index sqlite-bind-uint64 ; + +: sqlite-bind-boolean-by-name ( handle name obj -- ) + >boolean 1 0 ? parameter-index sqlite-bind-int ; + +: sqlite-bind-double-by-name ( handle name double -- ) + parameter-index sqlite-bind-double ; + +: sqlite-bind-blob-by-name ( handle name blob -- ) + parameter-index sqlite-bind-blob ; + +: sqlite-bind-null-by-name ( handle name obj -- ) + parameter-index drop sqlite-bind-null ; + +: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ; +: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ; +: sqlite-clear-bindings ( handle -- ) + sqlite3_clear_bindings sqlite-check-result ; +: sqlite-#columns ( query -- int ) sqlite3_column_count ; +: sqlite-column ( handle index -- string ) sqlite3_column_text ; +: sqlite-column-name ( handle index -- string ) sqlite3_column_name ; +: sqlite-column-type ( handle index -- string ) sqlite3_column_type ; + +: sqlite-column-blob ( handle index -- byte-array/f ) + [ sqlite3_column_bytes ] 2keep + pick zero? [ + 3drop f + ] [ + sqlite3_column_blob swap memory>byte-array + ] if ; + +: sqlite-step-has-more-rows? ( prepared -- ? ) + { + { SQLITE_ROW [ t ] } + { SQLITE_DONE [ f ] } + [ sqlite-check-result f ] + } case ; + +: sqlite-next ( prepared -- ? ) + sqlite3_step sqlite-step-has-more-rows? ; diff --git a/extra/db2/sqlite/sqlite.factor b/extra/db2/sqlite/sqlite.factor new file mode 100644 index 0000000000..edb74dd06f --- /dev/null +++ b/extra/db2/sqlite/sqlite.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: ; +IN: db2.sqlite diff --git a/extra/db2/sqlite/types/authors.txt b/extra/db2/sqlite/types/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/db2/sqlite/types/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/db2/sqlite/types/types.factor b/extra/db2/sqlite/types/types.factor new file mode 100644 index 0000000000..86ad92c60e --- /dev/null +++ b/extra/db2/sqlite/types/types.factor @@ -0,0 +1,62 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays calendar.format combinators db2.types +db2.sqlite.ffi db2.sqlite.lib +kernel present sequences serialize urls ; +IN: db2.sqlite.types + +: (bind-sqlite-type) ( handle key value type -- ) + dup array? [ first ] when + { + { INTEGER [ sqlite-bind-int-by-name ] } + { BIG-INTEGER [ sqlite-bind-int64-by-name ] } + { SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] } + { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] } + { BOOLEAN [ sqlite-bind-boolean-by-name ] } + { TEXT [ sqlite-bind-text-by-name ] } + { VARCHAR [ sqlite-bind-text-by-name ] } + { DOUBLE [ sqlite-bind-double-by-name ] } + { DATE [ timestamp>ymd sqlite-bind-text-by-name ] } + { TIME [ timestamp>hms sqlite-bind-text-by-name ] } + { DATETIME [ timestamp>ymdhms sqlite-bind-text-by-name ] } + { TIMESTAMP [ timestamp>ymdhms sqlite-bind-text-by-name ] } + { BLOB [ sqlite-bind-blob-by-name ] } + { FACTOR-BLOB [ object>bytes sqlite-bind-blob-by-name ] } + { URL [ present sqlite-bind-text-by-name ] } + { +db-assigned-id+ [ sqlite-bind-int-by-name ] } + { +random-id+ [ sqlite-bind-int64-by-name ] } + { NULL [ sqlite-bind-null-by-name ] } + [ no-sql-type ] + } case ; + +: bind-sqlite-type ( handle key value type -- ) + #! null and empty values need to be set by sqlite-bind-null-by-name + over [ + NULL = [ 2drop NULL NULL ] when + ] [ + drop NULL + ] if* (bind-sqlite-type) ; + +: sqlite-type ( handle index type -- obj ) + dup array? [ first ] when + { + { +db-assigned-id+ [ sqlite3_column_int64 ] } + { +random-id+ [ sqlite3-column-uint64 ] } + { INTEGER [ sqlite3_column_int ] } + { BIG-INTEGER [ sqlite3_column_int64 ] } + { SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] } + { UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] } + { BOOLEAN [ sqlite3_column_int 1 = ] } + { DOUBLE [ sqlite3_column_double ] } + { TEXT [ sqlite3_column_text ] } + { VARCHAR [ sqlite3_column_text ] } + { DATE [ sqlite3_column_text [ ymd>timestamp ] ?when ] } + { TIME [ sqlite3_column_text [ hms>timestamp ] ?when ] } + { TIMESTAMP [ sqlite3_column_text [ ymdhms>timestamp ] ?when ] } + { DATETIME [ sqlite3_column_text [ ymdhms>timestamp ] ?when ] } + { BLOB [ sqlite-column-blob ] } + { URL [ sqlite3_column_text [ >url ] ?when ] } + { FACTOR-BLOB [ sqlite-column-blob [ bytes>object ] ?when ] } + [ no-sql-type ] + } case ; + diff --git a/extra/db2/transactions/transactions.factor b/extra/db2/transactions/transactions.factor index 081c8dbe57..eb8c48e336 100644 --- a/extra/db2/transactions/transactions.factor +++ b/extra/db2/transactions/transactions.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: db2 ; +USING: continuations db2 db2.connections namespaces ; IN: db2.transactions -! Transactions SYMBOL: in-transaction HOOK: begin-transaction db-connection ( -- ) diff --git a/extra/db2/types/authors.txt b/extra/db2/types/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/db2/types/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/db2/types/types.factor b/extra/db2/types/types.factor new file mode 100644 index 0000000000..97f9ca0a0c --- /dev/null +++ b/extra/db2/types/types.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: ; +IN: db2.types + +SINGLETONS: +db-assigned-id+ +user-assigned-id+ +random-id+ ; +UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ; + +SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ ++foreign-id+ +has-many+ +on-update+ +on-delete+ +restrict+ +cascade+ ++set-null+ +set-default+ ; + +SINGLETONS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER +DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB +FACTOR-BLOB NULL URL ; + +ERROR: no-sql-type type ; From dd9ef140f98b93ea0a648bc8b7307593aca5df5a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 11 Apr 2009 13:46:25 -0500 Subject: [PATCH 03/98] gitignore a.out --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 22dda8efb4..aa877b1cb5 100644 --- a/.gitignore +++ b/.gitignore @@ -25,3 +25,4 @@ build-support/wordsize .#* *.swo checksums.txt +a.out From badbd014be33b04e5a26a9ed6dd9b646f4a64317 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 11 Apr 2009 16:19:41 -0500 Subject: [PATCH 04/98] more parsers for c syntax --- .../sequence-parser-tests.factor | 15 ++- extra/sequence-parser/sequence-parser.factor | 102 +++++++++++------- 2 files changed, 80 insertions(+), 37 deletions(-) diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor index 3b2fcad5eb..da097f4c00 100644 --- a/extra/sequence-parser/sequence-parser-tests.factor +++ b/extra/sequence-parser/sequence-parser-tests.factor @@ -1,4 +1,5 @@ -USING: tools.test sequence-parser ascii kernel accessors ; +USING: tools.test sequence-parser unicode.categories kernel +accessors ; IN: sequence-parser.tests [ "hello" ] @@ -189,3 +190,15 @@ IN: sequence-parser.tests [ "123u" ] [ "123u" take-c-integer ] unit-test + +[ 36 ] +[ + " //jofiejoe\n //eoieow\n/*asdf*/\n " + skip-whitespace/comments n>> +] unit-test + +[ f ] +[ "\n" take-integer ] unit-test + +[ "\n" ] [ "\n" [ ] take-while ] unit-test +[ f ] [ "\n" [ not ] take-while ] unit-test diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor index 4f57a7ccae..4cc10fd5fd 100644 --- a/extra/sequence-parser/sequence-parser.factor +++ b/extra/sequence-parser/sequence-parser.factor @@ -52,7 +52,7 @@ TUPLE: sequence-parser sequence n ; ] [ [ drop n>> ] [ skip-until ] - [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq + [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like ] if ; inline : take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f ) @@ -104,6 +104,45 @@ TUPLE: sequence-parser sequence n ; : skip-whitespace ( sequence-parser -- sequence-parser ) [ [ current blank? not ] take-until drop ] keep ; +: skip-whitespace-eol ( sequence-parser -- sequence-parser ) + [ [ current " \t\r" member? not ] take-until drop ] keep ; + +: take-c-comment ( sequence-parser -- seq/f ) + [ + dup "/*" take-sequence [ + "*/" take-until-sequence* + ] [ + drop f + ] if + ] with-sequence-parser ; + +: take-c++-comment ( sequence-parser -- seq/f ) + [ + dup "//" take-sequence [ + [ + [ + { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1|| + ] take-until + ] [ + advance drop + ] bi + ] [ + drop f + ] if + ] with-sequence-parser ; + +: skip-whitespace/comments ( sequence-parser -- sequence-parser ) + skip-whitespace-eol + { + { [ dup take-c-comment ] [ skip-whitespace/comments ] } + { [ dup take-c++-comment ] [ skip-whitespace/comments ] } + [ ] + } cond ; + +: take-define-identifier ( sequence-parser -- string ) + skip-whitespace/comments + [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ; + : take-rest-slice ( sequence-parser -- sequence/f ) [ sequence>> ] [ n>> ] bi 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline @@ -157,30 +196,6 @@ TUPLE: sequence-parser sequence n ; sequence-parser [ n + ] change-n drop ] if ; -: take-c-comment ( sequence-parser -- seq/f ) - [ - dup "/*" take-sequence [ - "*/" take-until-sequence* - ] [ - drop f - ] if - ] with-sequence-parser ; - -: take-c++-comment ( sequence-parser -- seq/f ) - [ - dup "//" take-sequence [ - [ - [ - { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1|| - ] take-until - ] [ - advance drop - ] bi - ] [ - drop f - ] if - ] with-sequence-parser ; - : c-identifier-begin? ( ch -- ? ) CHAR: a CHAR: z [a,b] CHAR: A CHAR: Z [a,b] @@ -192,29 +207,30 @@ TUPLE: sequence-parser sequence n ; CHAR: 0 CHAR: 9 [a,b] { CHAR: _ } 4 nappend member? ; -: take-c-identifier ( state-parser -- string/f ) - [ - dup current c-identifier-begin? [ - [ current c-identifier-ch? ] take-while - ] [ - drop f - ] if - ] with-sequence-parser ; +: (take-c-identifier) ( sequence-parser -- string/f ) + dup current c-identifier-begin? [ + [ current c-identifier-ch? ] take-while + ] [ + drop f + ] if ; + +: take-c-identifier ( sequence-parser -- string/f ) + [ (take-c-identifier) ] with-sequence-parser ; << "length" [ length ] define-sorting >> : sort-tokens ( seq -- seq' ) { length>=< <=> } sort-by ; -: take-first-matching ( state-parser seq -- seq ) +: take-first-matching ( sequence-parser seq -- seq ) swap '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ; -: take-longest ( state-parser seq -- seq ) +: take-longest ( sequence-parser seq -- seq ) sort-tokens take-first-matching ; -: take-c-integer ( state-parser -- string/f ) +: take-c-integer ( sequence-parser -- string/f ) [ dup take-integer [ swap @@ -225,5 +241,19 @@ TUPLE: sequence-parser sequence n ; ] if* ] with-sequence-parser ; +CONSTANT: c-punctuators + { + "[" "]" "(" ")" "{" "}" "." "->" + "++" "--" "&" "*" "+" "-" "~" "!" + "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "^" "|" "&&" "||" + "?" ":" ";" "..." + "=" "*=" "/=" "%=" "+=" "-=" "<<=" ">>=" "&=" "^=" "|=" + "," "#" "##" + "<:" ":>" "<%" "%>" "%:" "%:%:" + } + +: take-c-punctuator ( sequence-parser -- string/f ) + c-punctuators take-longest ; + : write-full ( sequence-parser -- ) sequence>> write ; : write-rest ( sequence-parser -- ) take-rest write ; From ee45c8ff20d357bb9fd4d2e15bcf88f3210b144c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 11 Apr 2009 20:21:04 -0500 Subject: [PATCH 05/98] more work on db2 --- extra/db2/connections/connections.factor | 12 +++++++++--- extra/db2/pools/pools-tests.factor | 9 +++++---- extra/db2/pools/pools.factor | 2 +- extra/db2/sqlite/sqlite.factor | 10 +++++++++- extra/db2/transactions/transactions.factor | 4 ++++ 5 files changed, 28 insertions(+), 9 deletions(-) diff --git a/extra/db2/connections/connections.factor b/extra/db2/connections/connections.factor index c622f9a4b4..faea6406fe 100644 --- a/extra/db2/connections/connections.factor +++ b/extra/db2/connections/connections.factor @@ -5,13 +5,19 @@ IN: db2.connections TUPLE: db-connection handle ; +: new-db-connection ( handle class -- db-connection ) + new + swap >>handle ; inline + GENERIC: db-open ( db -- db-connection ) -HOOK: db-close db-connection ( handle -- ) + +GENERIC: db-close ( handle -- ) + HOOK: parse-db-error db-connection ( error -- error' ) M: db-connection dispose ( db-connection -- ) - [ db-close f ] change-handle drop ; + [ db-close ] [ f >>handle drop ] bi ; : with-db ( db quot -- ) - [ db-open db-connection dup ] dip + [ db-open db-connection over ] dip '[ _ [ drop @ ] with-disposal ] with-variable ; inline diff --git a/extra/db2/pools/pools-tests.factor b/extra/db2/pools/pools-tests.factor index 7ff2a33d92..d61b745b03 100644 --- a/extra/db2/pools/pools-tests.factor +++ b/extra/db2/pools/pools-tests.factor @@ -1,6 +1,8 @@ -IN: db.pools.tests -USING: db.pools tools.test continuations io.files io.files.temp -io.directories namespaces accessors kernel math destructors ; +USING: accessors continuations db2.pools db2.sqlite +db2.sqlite.connections destructors io.directories io.files +io.files.temp kernel math namespaces tools.test +db2.sqlite.connections ; +IN: db2.pools.tests \ must-infer @@ -9,7 +11,6 @@ io.directories namespaces accessors kernel math destructors ; { 1 0 } [ [ ] with-pooled-db ] must-infer-as ! Test behavior after image save/load -USE: db.sqlite [ "pool-test.db" temp-file delete-file ] ignore-errors diff --git a/extra/db2/pools/pools.factor b/extra/db2/pools/pools.factor index b22dbde398..2b1aa2f0bf 100644 --- a/extra/db2/pools/pools.factor +++ b/extra/db2/pools/pools.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors db2.connections fry io.pools kernel namespaces ; -IN: db.pools +IN: db2.pools TUPLE: db-pool < pool db ; diff --git a/extra/db2/sqlite/sqlite.factor b/extra/db2/sqlite/sqlite.factor index edb74dd06f..82337ae30b 100644 --- a/extra/db2/sqlite/sqlite.factor +++ b/extra/db2/sqlite/sqlite.factor @@ -1,4 +1,12 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: ; +USING: constructors db2.connections ; IN: db2.sqlite + +TUPLE: sqlite-db path ; +CONSTRUCTOR: sqlite-db ( path -- sqlite-db ) ; + +TUPLE: sqlite-db-connection < db-connection ; + +: ( handle -- db-connection ) + sqlite-db-connection new-db-connection ; diff --git a/extra/db2/transactions/transactions.factor b/extra/db2/transactions/transactions.factor index eb8c48e336..fd0e6ade74 100644 --- a/extra/db2/transactions/transactions.factor +++ b/extra/db2/transactions/transactions.factor @@ -6,11 +6,15 @@ IN: db2.transactions SYMBOL: in-transaction HOOK: begin-transaction db-connection ( -- ) + HOOK: commit-transaction db-connection ( -- ) + HOOK: rollback-transaction db-connection ( -- ) M: db-connection begin-transaction ( -- ) "BEGIN" sql-command ; + M: db-connection commit-transaction ( -- ) "COMMIT" sql-command ; + M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ; : in-transaction? ( -- ? ) in-transaction get ; From 956a119991c360b577c04b7b4f460bf4603c27e3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 11 Apr 2009 21:05:18 -0500 Subject: [PATCH 06/98] still working on db2 --- .../db2/connections/connections-tests.factor | 8 ++ extra/db2/connections/connections.factor | 2 - extra/db2/db2-tests.factor | 5 + extra/db2/errors/errors.factor | 4 +- .../errors/postgresql/postgresql-tests.factor | 32 ------- extra/db2/errors/postgresql/postgresql.factor | 53 ---------- extra/db2/errors/sqlite/sqlite-tests.factor | 26 ----- .../connections}/authors.txt | 0 .../connections/connections-tests.factor | 4 + .../db2/sqlite/connections/connections.factor | 22 +++++ .../{errors/sqlite => sqlite/db}/authors.txt | 0 extra/db2/sqlite/db/db.factor | 12 +++ extra/db2/sqlite/errors/authors.txt | 1 + .../errors/errors.factor} | 23 +++-- extra/db2/sqlite/lib/lib.factor | 11 +-- extra/db2/sqlite/result-sets/authors.txt | 1 + .../db2/sqlite/result-sets/result-sets.factor | 7 ++ extra/db2/sqlite/statements/authors.txt | 1 + extra/db2/sqlite/statements/statements.factor | 11 +++ extra/db2/statements/statements-tests.factor | 13 +++ extra/db2/tester/authors.txt | 2 + extra/db2/tester/tester-tests.factor | 7 ++ extra/db2/tester/tester.factor | 96 +++++++++++++++++++ 23 files changed, 210 insertions(+), 131 deletions(-) create mode 100644 extra/db2/connections/connections-tests.factor create mode 100644 extra/db2/db2-tests.factor delete mode 100644 extra/db2/errors/postgresql/postgresql-tests.factor delete mode 100644 extra/db2/errors/postgresql/postgresql.factor delete mode 100644 extra/db2/errors/sqlite/sqlite-tests.factor rename extra/db2/{errors/postgresql => sqlite/connections}/authors.txt (100%) create mode 100644 extra/db2/sqlite/connections/connections-tests.factor create mode 100644 extra/db2/sqlite/connections/connections.factor rename extra/db2/{errors/sqlite => sqlite/db}/authors.txt (100%) create mode 100644 extra/db2/sqlite/db/db.factor create mode 100644 extra/db2/sqlite/errors/authors.txt rename extra/db2/{errors/sqlite/sqlite.factor => sqlite/errors/errors.factor} (50%) create mode 100644 extra/db2/sqlite/result-sets/authors.txt create mode 100644 extra/db2/sqlite/result-sets/result-sets.factor create mode 100644 extra/db2/sqlite/statements/authors.txt create mode 100644 extra/db2/sqlite/statements/statements.factor create mode 100644 extra/db2/statements/statements-tests.factor create mode 100644 extra/db2/tester/authors.txt create mode 100644 extra/db2/tester/tester-tests.factor create mode 100644 extra/db2/tester/tester.factor diff --git a/extra/db2/connections/connections-tests.factor b/extra/db2/connections/connections-tests.factor new file mode 100644 index 0000000000..f96a201bf6 --- /dev/null +++ b/extra/db2/connections/connections-tests.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test db2.connections db2.tester ; +IN: db2.connections.tests + +! Tests connection + +{ 1 0 } [ [ ] with-db ] must-infer-as diff --git a/extra/db2/connections/connections.factor b/extra/db2/connections/connections.factor index faea6406fe..0caee54726 100644 --- a/extra/db2/connections/connections.factor +++ b/extra/db2/connections/connections.factor @@ -10,9 +10,7 @@ TUPLE: db-connection handle ; swap >>handle ; inline GENERIC: db-open ( db -- db-connection ) - GENERIC: db-close ( handle -- ) - HOOK: parse-db-error db-connection ( error -- error' ) M: db-connection dispose ( db-connection -- ) diff --git a/extra/db2/db2-tests.factor b/extra/db2/db2-tests.factor new file mode 100644 index 0000000000..30ee7b3581 --- /dev/null +++ b/extra/db2/db2-tests.factor @@ -0,0 +1,5 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test db2 kernel ; +IN: db2.tests + diff --git a/extra/db2/errors/errors.factor b/extra/db2/errors/errors.factor index bd330e6191..45353f6fb9 100644 --- a/extra/db2/errors/errors.factor +++ b/extra/db2/errors/errors.factor @@ -1,10 +1,12 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel continuations fry words constructors ; +USING: accessors kernel continuations fry words constructors +db2.connections ; IN: db2.errors ERROR: db-error ; ERROR: sql-error location ; +HOOK: parse-sql-error db-connection ( error -- error' ) ERROR: sql-unknown-error < sql-error message ; CONSTRUCTOR: sql-unknown-error ( message -- error ) ; diff --git a/extra/db2/errors/postgresql/postgresql-tests.factor b/extra/db2/errors/postgresql/postgresql-tests.factor deleted file mode 100644 index f6668031e5..0000000000 --- a/extra/db2/errors/postgresql/postgresql-tests.factor +++ /dev/null @@ -1,32 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators.short-circuit db db.errors -db.errors.postgresql db.postgresql io.files.unique kernel namespaces -tools.test db.tester continuations ; -IN: db.errors.postgresql.tests - -[ - - [ "drop table foo;" sql-command ] ignore-errors - [ "drop table ship;" sql-command ] ignore-errors - - [ - "insert into foo (id) values('1');" sql-command - ] [ - { [ sql-table-missing? ] [ table>> "foo" = ] } 1&& - ] must-fail-with - - [ - "create table ship(id integer);" sql-command - "create table ship(id integer);" sql-command - ] [ - { [ sql-table-exists? ] [ table>> "ship" = ] } 1&& - ] must-fail-with - - [ - "create table foo(id) lol;" sql-command - ] [ - sql-syntax-error? - ] must-fail-with - -] test-postgresql diff --git a/extra/db2/errors/postgresql/postgresql.factor b/extra/db2/errors/postgresql/postgresql.factor deleted file mode 100644 index 02b43ecd88..0000000000 --- a/extra/db2/errors/postgresql/postgresql.factor +++ /dev/null @@ -1,53 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel db.errors peg.ebnf strings sequences math -combinators.short-circuit accessors math.parser quoting ; -IN: db.errors.postgresql - -EBNF: parse-postgresql-sql-error - -Error = "ERROR:" [ ]+ - -TableError = - Error ("relation "|"table ")(!(" already exists").)+:table " already exists" - => [[ table >string unquote ]] - | Error ("relation "|"table ")(!(" does not exist").)+:table " does not exist" - => [[ table >string unquote ]] - -FunctionError = - Error "function" (!(" already exists").)+:table " already exists" - => [[ table >string ]] - | Error "function" (!(" does not exist").)+:table " does not exist" - => [[ table >string ]] - -SyntaxError = - Error "syntax error at end of input":error - => [[ error >string ]] - | Error "syntax error at or near " .+:syntaxerror - => [[ syntaxerror >string unquote ]] - -UnknownError = .* => [[ >string ]] - -PostgresqlSqlError = (TableError | FunctionError | SyntaxError | UnknownError) - -;EBNF - - -ERROR: parse-postgresql-location column line text ; -C: parse-postgresql-location - -EBNF: parse-postgresql-line-error - -Line = "LINE " [0-9]+:line ": " .+:sql - => [[ f line >string string>number sql >string ]] - -;EBNF - -:: set-caret-position ( error caret-line -- error ) - caret-line length - error line>> number>string length "LINE : " length + - - [ error ] dip >>column ; - -: postgresql-location ( line column -- obj ) - [ parse-postgresql-line-error ] dip - set-caret-position ; diff --git a/extra/db2/errors/sqlite/sqlite-tests.factor b/extra/db2/errors/sqlite/sqlite-tests.factor deleted file mode 100644 index 68ae55f8a8..0000000000 --- a/extra/db2/errors/sqlite/sqlite-tests.factor +++ /dev/null @@ -1,26 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators.short-circuit db db.errors -db.errors.sqlite db.sqlite io.files.unique kernel namespaces -tools.test ; -IN: db.errors.sqlite.tests - -: sqlite-error-test-db-path ( -- path ) - "sqlite" "error-test" make-unique-file ; - -sqlite-error-test-db-path [ - - [ - "insert into foo (id) values('1');" sql-command - ] [ - { [ sql-table-missing? ] [ table>> "foo" = ] } 1&& - ] must-fail-with - - [ - "create table foo(id);" sql-command - "create table foo(id);" sql-command - ] [ - { [ sql-table-exists? ] [ table>> "foo" = ] } 1&& - ] must-fail-with - -] with-db \ No newline at end of file diff --git a/extra/db2/errors/postgresql/authors.txt b/extra/db2/sqlite/connections/authors.txt similarity index 100% rename from extra/db2/errors/postgresql/authors.txt rename to extra/db2/sqlite/connections/authors.txt diff --git a/extra/db2/sqlite/connections/connections-tests.factor b/extra/db2/sqlite/connections/connections-tests.factor new file mode 100644 index 0000000000..ed80810508 --- /dev/null +++ b/extra/db2/sqlite/connections/connections-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test db2.sqlite.connections ; +IN: db2.sqlite.connections.tests diff --git a/extra/db2/sqlite/connections/connections.factor b/extra/db2/sqlite/connections/connections.factor new file mode 100644 index 0000000000..ba9869633b --- /dev/null +++ b/extra/db2/sqlite/connections/connections.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators db2.connections db2.sqlite +db2.sqlite.errors db2.sqlite.lib kernel ; +IN: db2.sqlite.connections + +TUPLE: sqlite-db-connection < db-connection ; + +: ( handle -- db-connection ) + sqlite-db-connection new-db-connection ; + +M: sqlite-db db-open ( db -- db-connection ) + path>> sqlite-open ; + +M: sqlite-db-connection db-close ( db-connection -- ) + handle>> sqlite-close ; + +M: sqlite-db-connection parse-db-error ( error -- error' ) + dup n>> { + { 1 [ string>> parse-sqlite-sql-error ] } + [ drop ] + } case ; diff --git a/extra/db2/errors/sqlite/authors.txt b/extra/db2/sqlite/db/authors.txt similarity index 100% rename from extra/db2/errors/sqlite/authors.txt rename to extra/db2/sqlite/db/authors.txt diff --git a/extra/db2/sqlite/db/db.factor b/extra/db2/sqlite/db/db.factor new file mode 100644 index 0000000000..d5d580cb1a --- /dev/null +++ b/extra/db2/sqlite/db/db.factor @@ -0,0 +1,12 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors ; +IN: db2.sqlite.db + +TUPLE: sqlite-db path ; + +: ( path -- sqlite-db ) + sqlite-db new + swap >>path ; + + diff --git a/extra/db2/sqlite/errors/authors.txt b/extra/db2/sqlite/errors/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/db2/sqlite/errors/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/db2/errors/sqlite/sqlite.factor b/extra/db2/sqlite/errors/errors.factor similarity index 50% rename from extra/db2/errors/sqlite/sqlite.factor rename to extra/db2/sqlite/errors/errors.factor index c73409b850..eff73b6796 100644 --- a/extra/db2/errors/sqlite/sqlite.factor +++ b/extra/db2/sqlite/errors/errors.factor @@ -1,22 +1,31 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators db kernel sequences peg.ebnf -strings db.errors ; -IN: db.errors.sqlite +USING: accessors combinators db2.connections db2.errors +db2.sqlite.ffi kernel locals namespaces peg.ebnf sequences +strings ; +IN: db2.sqlite.errors + +ERROR: sqlite-error < db-error n string ; +ERROR: sqlite-sql-error < sql-error n string ; + +: throw-sqlite-error ( n -- * ) + dup sqlite-error-messages nth sqlite-error ; + +: sqlite-statement-error ( -- * ) + SQLITE_ERROR + db-connection get handle>> sqlite3_errmsg sqlite-sql-error ; TUPLE: unparsed-sqlite-error error ; C: unparsed-sqlite-error -SINGLETONS: table-exists table-missing ; - : sqlite-table-error ( table message -- error ) { - { table-exists [ ] } + { sql-table-exists [ ] } } case ; EBNF: parse-sqlite-sql-error -TableMessage = " already exists" => [[ table-exists ]] +TableMessage = " already exists" => [[ sql-table-exists ]] SqliteError = "table " (!(TableMessage).)+:table TableMessage:message diff --git a/extra/db2/sqlite/lib/lib.factor b/extra/db2/sqlite/lib/lib.factor index 2fe6d9cbdf..f3e3058582 100644 --- a/extra/db2/sqlite/lib/lib.factor +++ b/extra/db2/sqlite/lib/lib.factor @@ -3,20 +3,11 @@ USING: accessors alien.c-types arrays calendar.format combinators db2.connections db2.sqlite.ffi db2.errors io.backend io.encodings.string io.encodings.utf8 kernel math -namespaces present sequences serialize urls ; +namespaces present sequences serialize urls db2.sqlite.errors ; IN: db2.sqlite.lib : ?when ( object quot -- object' ) dupd when ; inline -ERROR: sqlite-error < db-error n string ; -ERROR: sqlite-sql-error < sql-error n string ; - -: throw-sqlite-error ( n -- * ) - dup sqlite-error-messages nth sqlite-error ; - -: sqlite-statement-error ( -- * ) - SQLITE_ERROR - db-connection get handle>> sqlite3_errmsg sqlite-sql-error ; : sqlite-check-result ( n -- ) { diff --git a/extra/db2/sqlite/result-sets/authors.txt b/extra/db2/sqlite/result-sets/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/db2/sqlite/result-sets/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/db2/sqlite/result-sets/result-sets.factor b/extra/db2/sqlite/result-sets/result-sets.factor new file mode 100644 index 0000000000..14e8e52f0e --- /dev/null +++ b/extra/db2/sqlite/result-sets/result-sets.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: db2.result-sets ; +IN: db2.sqlite.result-sets + +TUPLE: sqlite-result-set < result-set has-more? ; + diff --git a/extra/db2/sqlite/statements/authors.txt b/extra/db2/sqlite/statements/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/db2/sqlite/statements/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/db2/sqlite/statements/statements.factor b/extra/db2/sqlite/statements/statements.factor new file mode 100644 index 0000000000..fde2de7bf6 --- /dev/null +++ b/extra/db2/sqlite/statements/statements.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: db2.connections db2.statements db2.sqlite.connections +db2.sqlite.lib ; +IN: db2.sqlite.statements + +TUPLE: sqlite-statement < statement ; + +M: sqlite-db-connection ( string in out -- obj ) + sqlite-statement new-statement ; + diff --git a/extra/db2/statements/statements-tests.factor b/extra/db2/statements/statements-tests.factor new file mode 100644 index 0000000000..548300b417 --- /dev/null +++ b/extra/db2/statements/statements-tests.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test db2.statements kernel ; +IN: db2.statements.tests + +{ 1 0 } [ [ drop ] statement-each ] must-infer-as +{ 1 1 } [ [ ] statement-map ] must-infer-as + +[ ] +[ + "insert into computer (name, os) values('rocky', 'mac');" + +] unit-test diff --git a/extra/db2/tester/authors.txt b/extra/db2/tester/authors.txt new file mode 100644 index 0000000000..f372b574ae --- /dev/null +++ b/extra/db2/tester/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Doug Coleman diff --git a/extra/db2/tester/tester-tests.factor b/extra/db2/tester/tester-tests.factor new file mode 100644 index 0000000000..b3e8f19e6a --- /dev/null +++ b/extra/db2/tester/tester-tests.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test db2.tester ; +IN: db2.tester.tests + +! [ ] [ sqlite-test-db db-tester ] unit-test +! [ ] [ sqlite-test-db db-tester2 ] unit-test diff --git a/extra/db2/tester/tester.factor b/extra/db2/tester/tester.factor new file mode 100644 index 0000000000..471752f413 --- /dev/null +++ b/extra/db2/tester/tester.factor @@ -0,0 +1,96 @@ +! Copyright (C) 2008 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.combinators db2.connections +db2.pools db2.sqlite db2.types fry io.files.temp kernel math +namespaces random threads tools.test combinators ; +IN: db2.tester +USE: multiline + +: sqlite-test-db ( -- sqlite-db ) + "tuples-test.db" temp-file ; + +! These words leak resources, but are useful for interactivel testing +: set-sqlite-db ( -- ) + sqlite-db db-open db-connection set ; + +: test-sqlite ( quot -- ) + '[ + [ ] [ sqlite-test-db _ with-db ] unit-test + ] call ; inline + +: test-dbs ( quot -- ) + { + [ test-sqlite ] + } cleave ; + +/* +: postgresql-test-db ( -- postgresql-db ) + + "localhost" >>host + "postgres" >>username + "thepasswordistrust" >>password + "factor-test" >>database ; + +: set-postgresql-db ( -- ) + postgresql-db db-open db-connection set ; + +: test-postgresql ( quot -- ) + '[ + os windows? cpu x86.64? and [ + [ ] [ postgresql-test-db _ with-db ] unit-test + ] unless + ] call ; inline + +TUPLE: test-1 id a b c ; + +test-1 "TEST1" { + { "id" "ID" INTEGER +db-assigned-id+ } + { "a" "A" { VARCHAR 256 } +not-null+ } + { "b" "B" { VARCHAR 256 } +not-null+ } + { "c" "C" { VARCHAR 256 } +not-null+ } +} define-persistent + +TUPLE: test-2 id x y z ; + +test-2 "TEST2" { + { "id" "ID" INTEGER +db-assigned-id+ } + { "x" "X" { VARCHAR 256 } +not-null+ } + { "y" "Y" { VARCHAR 256 } +not-null+ } + { "z" "Z" { VARCHAR 256 } +not-null+ } +} define-persistent + +: db-tester ( test-db -- ) + [ + [ + test-1 ensure-table + test-2 ensure-table + ] with-db + ] [ + 10 [ + drop + 10 [ + dup [ + f 100 random 100 random 100 random test-1 boa + insert-tuple yield + ] with-db + ] times + ] with parallel-each + ] bi ; + +: db-tester2 ( test-db -- ) + [ + [ + test-1 ensure-table + test-2 ensure-table + ] with-db + ] [ + [ + 10 [ + 10 [ + f 100 random 100 random 100 random test-1 boa + insert-tuple yield + ] times + ] parallel-each + ] with-pooled-db + ] bi ; +*/ From 48a0858135321fda82cc02befb147ffca87f382f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 13 Apr 2009 15:37:29 -0500 Subject: [PATCH 07/98] raw sql queries work again --- extra/db2/connections/connections.factor | 1 - extra/db2/db2.factor | 1 + .../db2/sqlite/connections/connections.factor | 4 +-- extra/db2/sqlite/errors/errors.factor | 18 +++++----- extra/db2/sqlite/lib/lib.factor | 1 - .../db2/sqlite/result-sets/result-sets.factor | 22 +++++++++++- extra/db2/sqlite/statements/statements.factor | 14 ++++++-- extra/db2/statements/statements-tests.factor | 35 ++++++++++++++++--- extra/db2/statements/statements.factor | 13 ++++--- 9 files changed, 82 insertions(+), 27 deletions(-) diff --git a/extra/db2/connections/connections.factor b/extra/db2/connections/connections.factor index 0caee54726..7957cb918a 100644 --- a/extra/db2/connections/connections.factor +++ b/extra/db2/connections/connections.factor @@ -11,7 +11,6 @@ TUPLE: db-connection handle ; GENERIC: db-open ( db -- db-connection ) GENERIC: db-close ( handle -- ) -HOOK: parse-db-error db-connection ( error -- error' ) M: db-connection dispose ( db-connection -- ) [ db-close ] [ f >>handle drop ] bi ; diff --git a/extra/db2/db2.factor b/extra/db2/db2.factor index 16afbd2782..e1723160c0 100644 --- a/extra/db2/db2.factor +++ b/extra/db2/db2.factor @@ -18,3 +18,4 @@ PRIVATE> : sql-query ( sql -- sequence ) f f [ statement>result-sequence ] with-disposal ; + diff --git a/extra/db2/sqlite/connections/connections.factor b/extra/db2/sqlite/connections/connections.factor index ba9869633b..b99603f4ef 100644 --- a/extra/db2/sqlite/connections/connections.factor +++ b/extra/db2/sqlite/connections/connections.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators db2.connections db2.sqlite -db2.sqlite.errors db2.sqlite.lib kernel ; +db2.sqlite.errors db2.sqlite.lib kernel db2.errors ; IN: db2.sqlite.connections TUPLE: sqlite-db-connection < db-connection ; @@ -15,7 +15,7 @@ M: sqlite-db db-open ( db -- db-connection ) M: sqlite-db-connection db-close ( db-connection -- ) handle>> sqlite-close ; -M: sqlite-db-connection parse-db-error ( error -- error' ) +M: sqlite-db-connection parse-sql-error ( error -- error' ) dup n>> { { 1 [ string>> parse-sqlite-sql-error ] } [ drop ] diff --git a/extra/db2/sqlite/errors/errors.factor b/extra/db2/sqlite/errors/errors.factor index eff73b6796..61e70f210d 100644 --- a/extra/db2/sqlite/errors/errors.factor +++ b/extra/db2/sqlite/errors/errors.factor @@ -8,9 +8,6 @@ IN: db2.sqlite.errors ERROR: sqlite-error < db-error n string ; ERROR: sqlite-sql-error < sql-error n string ; -: throw-sqlite-error ( n -- * ) - dup sqlite-error-messages nth sqlite-error ; - : sqlite-statement-error ( -- * ) SQLITE_ERROR db-connection get handle>> sqlite3_errmsg sqlite-sql-error ; @@ -18,20 +15,21 @@ ERROR: sqlite-sql-error < sql-error n string ; TUPLE: unparsed-sqlite-error error ; C: unparsed-sqlite-error -: sqlite-table-error ( table message -- error ) - { - { sql-table-exists [ ] } - } case ; - EBNF: parse-sqlite-sql-error -TableMessage = " already exists" => [[ sql-table-exists ]] +TableMessage = " already exists" +SyntaxError = ": syntax error" SqliteError = "table " (!(TableMessage).)+:table TableMessage:message - => [[ table >string message sqlite-table-error ]] + => [[ table >string ]] + | "near " (!(SyntaxError).)+:syntax SyntaxError:message + => [[ syntax >string ]] | "no such table: " .+:table => [[ table >string ]] | .*:error => [[ error >string ]] ;EBNF + +: throw-sqlite-error ( n -- * ) + dup sqlite-error-messages nth sqlite-error ; diff --git a/extra/db2/sqlite/lib/lib.factor b/extra/db2/sqlite/lib/lib.factor index f3e3058582..34918efb8d 100644 --- a/extra/db2/sqlite/lib/lib.factor +++ b/extra/db2/sqlite/lib/lib.factor @@ -8,7 +8,6 @@ IN: db2.sqlite.lib : ?when ( object quot -- object' ) dupd when ; inline - : sqlite-check-result ( n -- ) { { SQLITE_OK [ ] } diff --git a/extra/db2/sqlite/result-sets/result-sets.factor b/extra/db2/sqlite/result-sets/result-sets.factor index 14e8e52f0e..a8bf11fc56 100644 --- a/extra/db2/sqlite/result-sets/result-sets.factor +++ b/extra/db2/sqlite/result-sets/result-sets.factor @@ -1,7 +1,27 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: db2.result-sets ; +USING: accessors db2.result-sets db2.sqlite.statements +db2.statements kernel db2.sqlite.lib destructors ; IN: db2.sqlite.result-sets TUPLE: sqlite-result-set < result-set has-more? ; +M: sqlite-result-set dispose + f >>handle drop ; + +M: sqlite-statement statement>result-set* + sqlite-maybe-prepare + dup handle>> sqlite-result-set new-result-set + dup advance-row ; + +M: sqlite-result-set advance-row ( result-set -- ) + dup handle>> sqlite-next >>has-more? drop ; + +M: sqlite-result-set more-rows? ( result-set -- ) + has-more?>> ; + +M: sqlite-result-set #columns ( result-set -- n ) + handle>> sqlite-#columns ; + +M: sqlite-result-set column ( result-set n -- obj ) + [ handle>> ] [ sqlite-column ] bi* ; diff --git a/extra/db2/sqlite/statements/statements.factor b/extra/db2/sqlite/statements/statements.factor index fde2de7bf6..a856c48075 100644 --- a/extra/db2/sqlite/statements/statements.factor +++ b/extra/db2/sqlite/statements/statements.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: db2.connections db2.statements db2.sqlite.connections -db2.sqlite.lib ; +USING: accessors db2.connections db2.sqlite.connections +db2.sqlite.ffi db2.sqlite.lib db2.statements destructors kernel +namespaces ; IN: db2.sqlite.statements TUPLE: sqlite-statement < statement ; @@ -9,3 +10,12 @@ TUPLE: sqlite-statement < statement ; M: sqlite-db-connection ( string in out -- obj ) sqlite-statement new-statement ; +M: sqlite-statement dispose + handle>> + [ [ sqlite3_reset drop ] [ sqlite-finalize ] bi ] when* ; + +: sqlite-maybe-prepare ( statement -- statement ) + dup handle>> [ + db-connection get handle>> over sql>> sqlite-prepare + >>handle + ] unless ; diff --git a/extra/db2/statements/statements-tests.factor b/extra/db2/statements/statements-tests.factor index 548300b417..43564c8b29 100644 --- a/extra/db2/statements/statements-tests.factor +++ b/extra/db2/statements/statements-tests.factor @@ -1,13 +1,38 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test db2.statements kernel ; +USING: tools.test db2.statements kernel db2 db2.tester +continuations db2.errors ; IN: db2.statements.tests { 1 0 } [ [ drop ] statement-each ] must-infer-as { 1 1 } [ [ ] statement-map ] must-infer-as -[ ] -[ - "insert into computer (name, os) values('rocky', 'mac');" + +: test-sql-command ( -- ) + [ "drop table computer;" sql-command ] ignore-errors + + [ ] [ + "create table computer(name varchar, os varchar);" + sql-command + ] unit-test -] unit-test + [ ] [ + "insert into computer (name, os) values('rocky', 'mac');" + sql-command + ] unit-test + + [ { { "rocky" "mac" } } ] + [ + "select name, os from computer;" sql-query + ] unit-test + + [ "insert into" sql-command ] + [ sql-syntax-error? ] must-fail-with + + [ "selectt" sql-query ] + [ sql-syntax-error? ] must-fail-with + + ; + +[ test-sql-command ] test-dbs + diff --git a/extra/db2/statements/statements.factor b/extra/db2/statements/statements.factor index 282fb7d5bf..006cda3532 100644 --- a/extra/db2/statements/statements.factor +++ b/extra/db2/statements/statements.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors continuations destructors fry kernel -sequences db2.result-sets db2.connections ; +sequences db2.result-sets db2.connections db2.errors ; IN: db2.statements -TUPLE: statement handle sql in out ; +TUPLE: statement handle sql in out type ; : new-statement ( sql in out class -- statement ) new @@ -13,12 +13,15 @@ TUPLE: statement handle sql in out ; swap >>sql ; HOOK: db-connection ( sql in out -- statement ) +GENERIC: statement>result-set* ( statement -- result-set ) GENERIC: execute-statement* ( statement type -- ) -GENERIC: statement>result-set ( statement -- result-set ) + +: statement>result-set ( statement -- result-set ) + [ statement>result-set* ] + [ dup sql-error? [ parse-sql-error ] when rethrow ] recover ; M: object execute-statement* ( statement type -- ) - drop '[ _ statement>result-set dispose ] - [ parse-db-error rethrow ] recover ; + drop statement>result-set dispose ; : execute-one-statement ( statement -- ) dup type>> execute-statement* ; From 1789a58bbfe5de47c3647bc6650e623558331544 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 13 Apr 2009 17:27:31 -0500 Subject: [PATCH 08/98] add sql-bind-query, sql-bind-command for writing raw sql --- extra/db2/db2.factor | 22 +++++++++++++++++-- extra/db2/result-sets/result-sets.factor | 12 ++++++---- .../db2/sqlite/result-sets/result-sets.factor | 2 +- extra/db2/statements/statements-tests.factor | 17 ++++++++++++-- 4 files changed, 44 insertions(+), 9 deletions(-) diff --git a/extra/db2/db2.factor b/extra/db2/db2.factor index e1723160c0..708caa97ab 100644 --- a/extra/db2/db2.factor +++ b/extra/db2/db2.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors continuations destructors fry kernel -namespaces sequences strings db2.statements ; +USING: accessors continuations db2.result-sets db2.sqlite.lib +db2.sqlite.result-sets db2.sqlite.statements db2.statements +destructors fry kernel math namespaces sequences strings ; IN: db2 : sql-query ( sql -- sequence ) f f [ statement>result-sequence ] with-disposal ; +: sql-bind-command ( sequence string -- ) + f f [ + sqlite-maybe-prepare [ + handle>> '[ [ _ ] 2dip 1+ swap sqlite-bind-text ] each-index + ] [ + sqlite-result-set new-result-set advance-row + ] bi + ] with-disposal ; + +: sql-bind-query ( in-sequence string -- out-sequence ) + f f [ + sqlite-maybe-prepare [ + handle>> '[ [ _ ] 2dip 1+ swap sqlite-bind-text ] each-index + ] [ + statement>result-sequence + ] bi + ] with-disposal ; diff --git a/extra/db2/result-sets/result-sets.factor b/extra/db2/result-sets/result-sets.factor index 8e35dc3862..6f69c26ab2 100644 --- a/extra/db2/result-sets/result-sets.factor +++ b/extra/db2/result-sets/result-sets.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences ; +USING: accessors kernel sequences combinators ; IN: db2.result-sets TUPLE: result-set sql in out handle n max ; @@ -16,10 +16,14 @@ GENERIC# column-typed 1 ( result-set column -- sql ) dup #rows >>max 0 >>n ; -: new-result-set ( query handle class -- result-set ) +: new-result-set ( query class -- result-set ) new - swap >>handle - swap [ sql>> >>sql ] [ in>> >>in ] [ out>> >>out ] tri ; + swap { + [ handle>> >>handle ] + [ sql>> >>sql ] + [ in>> >>in ] + [ out>> >>out ] + } cleave ; : sql-row ( result-set -- seq ) dup #columns [ column ] with map ; diff --git a/extra/db2/sqlite/result-sets/result-sets.factor b/extra/db2/sqlite/result-sets/result-sets.factor index a8bf11fc56..e77ade567a 100644 --- a/extra/db2/sqlite/result-sets/result-sets.factor +++ b/extra/db2/sqlite/result-sets/result-sets.factor @@ -11,7 +11,7 @@ M: sqlite-result-set dispose M: sqlite-statement statement>result-set* sqlite-maybe-prepare - dup handle>> sqlite-result-set new-result-set + sqlite-result-set new-result-set dup advance-row ; M: sqlite-result-set advance-row ( result-set -- ) diff --git a/extra/db2/statements/statements-tests.factor b/extra/db2/statements/statements-tests.factor index 43564c8b29..6afcfb0c95 100644 --- a/extra/db2/statements/statements-tests.factor +++ b/extra/db2/statements/statements-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: tools.test db2.statements kernel db2 db2.tester -continuations db2.errors ; +continuations db2.errors accessors ; IN: db2.statements.tests { 1 0 } [ [ drop ] statement-each ] must-infer-as @@ -11,6 +11,9 @@ IN: db2.statements.tests : test-sql-command ( -- ) [ "drop table computer;" sql-command ] ignore-errors + [ "drop table computer;" sql-command ] + [ [ sql-table-missing? ] [ table>> "computer" = ] bi and ] must-fail-with + [ ] [ "create table computer(name varchar, os varchar);" sql-command @@ -32,7 +35,17 @@ IN: db2.statements.tests [ "selectt" sql-query ] [ sql-syntax-error? ] must-fail-with + [ ] [ + { "clubber" "windows" } + "insert into computer (name, os) values(?, ?);" + sql-bind-command + ] unit-test + + [ { { "windows" } } ] [ + { "clubber" } + "select os from computer where name = ?;" sql-bind-query + ] unit-test + ; [ test-sql-command ] test-dbs - From c9db0fdee1f4ff607a9c9ca1316e0878bf850cc5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 13 Apr 2009 17:40:35 -0500 Subject: [PATCH 09/98] refactor sqlite bind --- extra/db2/db2.factor | 4 ++-- extra/db2/sqlite/lib/lib.factor | 6 ++++++ 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/extra/db2/db2.factor b/extra/db2/db2.factor index 708caa97ab..8278d18598 100644 --- a/extra/db2/db2.factor +++ b/extra/db2/db2.factor @@ -23,7 +23,7 @@ PRIVATE> : sql-bind-command ( sequence string -- ) f f [ sqlite-maybe-prepare [ - handle>> '[ [ _ ] 2dip 1+ swap sqlite-bind-text ] each-index + handle>> swap sqlite-bind-sequence ] [ sqlite-result-set new-result-set advance-row ] bi @@ -32,7 +32,7 @@ PRIVATE> : sql-bind-query ( in-sequence string -- out-sequence ) f f [ sqlite-maybe-prepare [ - handle>> '[ [ _ ] 2dip 1+ swap sqlite-bind-text ] each-index + handle>> swap sqlite-bind-sequence ] [ statement>result-sequence ] bi diff --git a/extra/db2/sqlite/lib/lib.factor b/extra/db2/sqlite/lib/lib.factor index 34918efb8d..26c56cbbd2 100644 --- a/extra/db2/sqlite/lib/lib.factor +++ b/extra/db2/sqlite/lib/lib.factor @@ -8,6 +8,9 @@ IN: db2.sqlite.lib : ?when ( object quot -- object' ) dupd when ; inline +: assoc-with ( object sequence quot -- obj curry ) + swapd [ [ -rot ] dip call ] 2curry ; inline + : sqlite-check-result ( n -- ) { { SQLITE_OK [ ] } @@ -107,3 +110,6 @@ IN: db2.sqlite.lib : sqlite-next ( prepared -- ? ) sqlite3_step sqlite-step-has-more-rows? ; + +: sqlite-bind-sequence ( handle sequence -- ) + [ 1+ swap sqlite-bind-text ] assoc-with each-index ; From 6db099977571285c35c97d48cb475095dd283e31 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 13 Apr 2009 18:04:06 -0500 Subject: [PATCH 10/98] add raw, typed bind statements --- extra/db2/db2.factor | 23 +++++++++++++-- extra/db2/sqlite/lib/lib.factor | 6 ++++ .../db2/sqlite/result-sets/result-sets.factor | 4 +-- extra/db2/sqlite/types/types.factor | 28 ++++++++++++++++++- extra/db2/statements/statements-tests.factor | 17 ++++++++++- 5 files changed, 71 insertions(+), 7 deletions(-) diff --git a/extra/db2/db2.factor b/extra/db2/db2.factor index 8278d18598..71f181e8d7 100644 --- a/extra/db2/db2.factor +++ b/extra/db2/db2.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors continuations db2.result-sets db2.sqlite.lib db2.sqlite.result-sets db2.sqlite.statements db2.statements -destructors fry kernel math namespaces sequences strings ; +destructors fry kernel math namespaces sequences strings +db2.sqlite.types ; IN: db2 sqlite-maybe-prepare [ handle>> swap sqlite-bind-sequence ] [ - sqlite-result-set new-result-set advance-row + >sqlite-result-set drop ] bi ] with-disposal ; @@ -37,3 +38,21 @@ PRIVATE> statement>result-sequence ] bi ] with-disposal ; + +: sql-bind-typed-command ( in-sequence string -- ) + f f [ + sqlite-maybe-prepare [ + handle>> swap sqlite-bind-typed-sequence + ] [ + >sqlite-result-set drop + ] bi + ] with-disposal ; + +: sql-bind-typed-query ( in-sequence string -- out-sequence ) + f f [ + sqlite-maybe-prepare [ + handle>> swap sqlite-bind-typed-sequence + ] [ + statement>result-sequence + ] bi + ] with-disposal ; diff --git a/extra/db2/sqlite/lib/lib.factor b/extra/db2/sqlite/lib/lib.factor index 26c56cbbd2..483987d803 100644 --- a/extra/db2/sqlite/lib/lib.factor +++ b/extra/db2/sqlite/lib/lib.factor @@ -50,6 +50,9 @@ IN: db2.sqlite.lib : sqlite-bind-uint64 ( handle i n -- ) sqlite3-bind-uint64 sqlite-check-result ; +: sqlite-bind-boolean ( handle name obj -- ) + >boolean 1 0 ? sqlite-bind-int ; + : sqlite-bind-double ( handle i x -- ) sqlite3_bind_double sqlite-check-result ; @@ -113,3 +116,6 @@ IN: db2.sqlite.lib : sqlite-bind-sequence ( handle sequence -- ) [ 1+ swap sqlite-bind-text ] assoc-with each-index ; + +: >sqlite-result-set ( statement -- result-set ) + sqlite-result-set new-result-set dup advance-row ; diff --git a/extra/db2/sqlite/result-sets/result-sets.factor b/extra/db2/sqlite/result-sets/result-sets.factor index e77ade567a..afc0c7bfc2 100644 --- a/extra/db2/sqlite/result-sets/result-sets.factor +++ b/extra/db2/sqlite/result-sets/result-sets.factor @@ -10,9 +10,7 @@ M: sqlite-result-set dispose f >>handle drop ; M: sqlite-statement statement>result-set* - sqlite-maybe-prepare - sqlite-result-set new-result-set - dup advance-row ; + sqlite-maybe-prepare >sqlite-result-set ; M: sqlite-result-set advance-row ( result-set -- ) dup handle>> sqlite-next >>has-more? drop ; diff --git a/extra/db2/sqlite/types/types.factor b/extra/db2/sqlite/types/types.factor index 86ad92c60e..5429de0d7c 100644 --- a/extra/db2/sqlite/types/types.factor +++ b/extra/db2/sqlite/types/types.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays calendar.format combinators db2.types -db2.sqlite.ffi db2.sqlite.lib +db2.sqlite.ffi db2.sqlite.lib math fry kernel present sequences serialize urls ; IN: db2.sqlite.types @@ -29,6 +29,30 @@ IN: db2.sqlite.types [ no-sql-type ] } case ; +: bind-next-sqlite-type ( handle key value type -- ) + dup array? [ first ] when + { + { INTEGER [ sqlite-bind-int ] } + { BIG-INTEGER [ sqlite-bind-int64 ] } + { SIGNED-BIG-INTEGER [ sqlite-bind-int64 ] } + { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64 ] } + { BOOLEAN [ sqlite-bind-boolean ] } + { TEXT [ sqlite-bind-text ] } + { VARCHAR [ sqlite-bind-text ] } + { DOUBLE [ sqlite-bind-double ] } + { DATE [ timestamp>ymd sqlite-bind-text ] } + { TIME [ timestamp>hms sqlite-bind-text ] } + { DATETIME [ timestamp>ymdhms sqlite-bind-text ] } + { TIMESTAMP [ timestamp>ymdhms sqlite-bind-text ] } + { BLOB [ sqlite-bind-blob ] } + { FACTOR-BLOB [ object>bytes sqlite-bind-blob ] } + { URL [ present sqlite-bind-text ] } + { +db-assigned-id+ [ sqlite-bind-int ] } + { +random-id+ [ sqlite-bind-int64 ] } + { NULL [ drop sqlite-bind-null ] } + [ no-sql-type ] + } case ; + : bind-sqlite-type ( handle key value type -- ) #! null and empty values need to be set by sqlite-bind-null-by-name over [ @@ -60,3 +84,5 @@ IN: db2.sqlite.types [ no-sql-type ] } case ; +: sqlite-bind-typed-sequence ( handle sequence -- ) + [ 1+ swap first2 swap bind-next-sqlite-type ] assoc-with each-index ; diff --git a/extra/db2/statements/statements-tests.factor b/extra/db2/statements/statements-tests.factor index 6afcfb0c95..ed4b7babb8 100644 --- a/extra/db2/statements/statements-tests.factor +++ b/extra/db2/statements/statements-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: tools.test db2.statements kernel db2 db2.tester -continuations db2.errors accessors ; +continuations db2.errors accessors db2.types ; IN: db2.statements.tests { 1 0 } [ [ drop ] statement-each ] must-infer-as @@ -46,6 +46,21 @@ IN: db2.statements.tests "select os from computer where name = ?;" sql-bind-query ] unit-test + [ { { "windows" } } ] [ + { { VARCHAR "clubber" } } + "select os from computer where name = ?;" sql-bind-typed-query + ] unit-test + + [ ] [ + { + { VARCHAR "clubber" } + { VARCHAR "windows" } + } + "insert into computer (name, os) values(?, ?);" + sql-bind-typed-command + ] unit-test + + ; [ test-sql-command ] test-dbs From 66a4ec5896b8819024ebd8db93a9eb40ef86adf9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 13 Apr 2009 18:19:37 -0500 Subject: [PATCH 11/98] more generics in the statement protocol --- extra/db2/db2.factor | 28 ++++++------------- extra/db2/sqlite/lib/lib.factor | 3 -- extra/db2/sqlite/statements/statements.factor | 8 ++---- extra/db2/sqlite/types/types.factor | 11 ++++++-- extra/db2/statements/statements.factor | 6 ++++ 5 files changed, 26 insertions(+), 30 deletions(-) diff --git a/extra/db2/db2.factor b/extra/db2/db2.factor index 71f181e8d7..8d4bfd19a0 100644 --- a/extra/db2/db2.factor +++ b/extra/db2/db2.factor @@ -23,36 +23,24 @@ PRIVATE> : sql-bind-command ( sequence string -- ) f f [ - sqlite-maybe-prepare [ - handle>> swap sqlite-bind-sequence - ] [ - >sqlite-result-set drop - ] bi + prepare-statement + [ bind-sequence ] [ statement>result-set drop ] bi ] with-disposal ; : sql-bind-query ( in-sequence string -- out-sequence ) f f [ - sqlite-maybe-prepare [ - handle>> swap sqlite-bind-sequence - ] [ - statement>result-sequence - ] bi + prepare-statement + [ bind-sequence ] [ statement>result-sequence ] bi ] with-disposal ; : sql-bind-typed-command ( in-sequence string -- ) f f [ - sqlite-maybe-prepare [ - handle>> swap sqlite-bind-typed-sequence - ] [ - >sqlite-result-set drop - ] bi + prepare-statement + [ bind-typed-sequence ] [ statement>result-set drop ] bi ] with-disposal ; : sql-bind-typed-query ( in-sequence string -- out-sequence ) f f [ - sqlite-maybe-prepare [ - handle>> swap sqlite-bind-typed-sequence - ] [ - statement>result-sequence - ] bi + prepare-statement + [ bind-typed-sequence ] [ statement>result-sequence ] bi ] with-disposal ; diff --git a/extra/db2/sqlite/lib/lib.factor b/extra/db2/sqlite/lib/lib.factor index 483987d803..f8503ee90f 100644 --- a/extra/db2/sqlite/lib/lib.factor +++ b/extra/db2/sqlite/lib/lib.factor @@ -114,8 +114,5 @@ IN: db2.sqlite.lib : sqlite-next ( prepared -- ? ) sqlite3_step sqlite-step-has-more-rows? ; -: sqlite-bind-sequence ( handle sequence -- ) - [ 1+ swap sqlite-bind-text ] assoc-with each-index ; - : >sqlite-result-set ( statement -- result-set ) sqlite-result-set new-result-set dup advance-row ; diff --git a/extra/db2/sqlite/statements/statements.factor b/extra/db2/sqlite/statements/statements.factor index a856c48075..64ce390308 100644 --- a/extra/db2/sqlite/statements/statements.factor +++ b/extra/db2/sqlite/statements/statements.factor @@ -14,8 +14,6 @@ M: sqlite-statement dispose handle>> [ [ sqlite3_reset drop ] [ sqlite-finalize ] bi ] when* ; -: sqlite-maybe-prepare ( statement -- statement ) - dup handle>> [ - db-connection get handle>> over sql>> sqlite-prepare - >>handle - ] unless ; +M: sqlite-statement prepare-statement* ( statement -- statement ) + db-connection get handle>> over sql>> sqlite-prepare + >>handle ; diff --git a/extra/db2/sqlite/types/types.factor b/extra/db2/sqlite/types/types.factor index 5429de0d7c..7124568fbe 100644 --- a/extra/db2/sqlite/types/types.factor +++ b/extra/db2/sqlite/types/types.factor @@ -84,5 +84,12 @@ IN: db2.sqlite.types [ no-sql-type ] } case ; -: sqlite-bind-typed-sequence ( handle sequence -- ) - [ 1+ swap first2 swap bind-next-sqlite-type ] assoc-with each-index ; +M: sqlite-statement bind-sequence ( sequence statement -- ) + handle>> '[ + [ _ ] 2dip 1+ swap sqlite-bind-text + ] each-index ; + +M: sqlite-statement bind-typed-sequence ( sequence statement -- ) + handle>> '[ + [ _ ] 2dip 1+ swap first2 swap bind-next-sqlite-type + ] each-index ; diff --git a/extra/db2/statements/statements.factor b/extra/db2/statements/statements.factor index 006cda3532..989391473d 100644 --- a/extra/db2/statements/statements.factor +++ b/extra/db2/statements/statements.factor @@ -15,6 +15,9 @@ TUPLE: statement handle sql in out type ; HOOK: db-connection ( sql in out -- statement ) GENERIC: statement>result-set* ( statement -- result-set ) GENERIC: execute-statement* ( statement type -- ) +GENERIC: prepare-statement* ( statement -- statement' ) +GENERIC: bind-sequence ( sequence statement -- ) +GENERIC: bind-typed-sequence ( sequence statement -- ) : statement>result-set ( statement -- result-set ) [ statement>result-set* ] @@ -31,6 +34,9 @@ M: object execute-statement* ( statement type -- ) [ [ execute-one-statement ] each ] [ execute-one-statement ] if ; +: prepare-statement ( statement -- statement ) + dup handle>> [ prepare-statement* ] unless ; + : statement-each ( statement quot: ( statement -- ) -- ) over more-rows? [ [ call ] 2keep over advance-row statement-each ] From d20fb81a9cbe778679702a903a72ca053c9b5c53 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 13 Apr 2009 19:51:19 -0500 Subject: [PATCH 12/98] working out the dispatch for bound queries, first stab at fql --- extra/db2/db2.factor | 45 +++++++---- extra/db2/fql/authors.txt | 1 + extra/db2/fql/fql-tests.factor | 27 +++++++ extra/db2/fql/fql.factor | 79 ++++++++++++++++++++ extra/db2/sqlite/lib/lib.factor | 10 +-- extra/db2/statements/statements-tests.factor | 17 +++-- extra/db2/utils/authors.txt | 1 + extra/db2/utils/utils.factor | 9 +++ 8 files changed, 161 insertions(+), 28 deletions(-) create mode 100644 extra/db2/fql/authors.txt create mode 100644 extra/db2/fql/fql-tests.factor create mode 100644 extra/db2/fql/fql.factor create mode 100644 extra/db2/utils/authors.txt create mode 100644 extra/db2/utils/utils.factor diff --git a/extra/db2/db2.factor b/extra/db2/db2.factor index 8d4bfd19a0..4687a6329f 100644 --- a/extra/db2/db2.factor +++ b/extra/db2/db2.factor @@ -6,41 +6,58 @@ destructors fry kernel math namespaces sequences strings db2.sqlite.types ; IN: db2 - [ execute-statement ] with-disposal ; -PRIVATE> - -: sql-command ( sql -- ) - dup string? - [ execute-sql-string ] - [ [ execute-sql-string ] each ] if ; - -: sql-query ( sql -- sequence ) +M: string sql-query ( sql -- sequence ) f f [ statement>result-sequence ] with-disposal ; -: sql-bind-command ( sequence string -- ) +M: string sql-bind-command* ( sequence string -- ) f f [ prepare-statement [ bind-sequence ] [ statement>result-set drop ] bi ] with-disposal ; -: sql-bind-query ( in-sequence string -- out-sequence ) +M: string sql-bind-query* ( in-sequence string -- out-sequence ) f f [ prepare-statement [ bind-sequence ] [ statement>result-sequence ] bi ] with-disposal ; -: sql-bind-typed-command ( in-sequence string -- ) +M: string sql-bind-typed-command* ( in-sequence string -- ) f f [ prepare-statement [ bind-typed-sequence ] [ statement>result-set drop ] bi ] with-disposal ; -: sql-bind-typed-query ( in-sequence string -- out-sequence ) +M: string sql-bind-typed-query* ( in-sequence string -- out-sequence ) f f [ prepare-statement [ bind-typed-sequence ] [ statement>result-sequence ] bi ] with-disposal ; + +M: sequence sql-command [ sql-command ] each ; +M: sequence sql-query [ sql-query ] map ; +M: sequence sql-bind-command* [ sql-bind-command* ] with each ; +M: sequence sql-bind-query* [ sql-bind-query* ] with map ; +M: sequence sql-bind-typed-command* [ sql-bind-typed-command* ] with each ; +M: sequence sql-bind-typed-query* [ sql-bind-typed-query* ] with map ; + +! M: string sql-command [ sql-command ] each ; +! M: string sql-query [ sql-query ] map ; +! M: string sql-bind-command* sql-bind-command* ; +! M: string sql-bind-query* sql-bind-query* ; +! M: string sql-bind-typed-command sql-bind-typed-command* ; +! M: string sql-bind-typed-query sql-bind-typed-query* ; diff --git a/extra/db2/fql/authors.txt b/extra/db2/fql/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/db2/fql/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/db2/fql/fql-tests.factor b/extra/db2/fql/fql-tests.factor new file mode 100644 index 0000000000..6a6f782b1e --- /dev/null +++ b/extra/db2/fql/fql-tests.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors db2 db2.fql db2.statements.tests db2.tester +kernel tools.test ; +IN: db2.fql.tests + +: test-fql ( -- ) + create-computer-table + + [ "insert into computer (name, os) values (?, ?);" ] + [ + "computer" { "name" "os" } { "lol" "os2" } expand-fql + sql>> + ] unit-test + + [ "select name, os from computer" ] + [ + select new + { "name" "os" } >>names + "computer" >>from + expand-fql sql>> + ] unit-test + + + ; + +[ test-fql ] test-dbs diff --git a/extra/db2/fql/fql.factor b/extra/db2/fql/fql.factor new file mode 100644 index 0000000000..78abc5ee0b --- /dev/null +++ b/extra/db2/fql/fql.factor @@ -0,0 +1,79 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators constructors db2 +db2.private db2.sqlite.lib db2.statements db2.utils destructors +kernel make math.parser sequences strings ; +IN: db2.fql + +TUPLE: fql-statement sql in out ; + +GENERIC: expand-fql* ( object -- sequence/fql-statement ) +GENERIC: normalize-fql ( object -- sequence/fql-statement ) + +! M: object normalize-fql ; + + +: ?1array ( obj -- array ) + dup string? [ 1array ] when ; inline + + +TUPLE: insert into names values ; +CONSTRUCTOR: insert ( into names values -- obj ) ; +M: insert normalize-fql ( insert -- insert ) + [ [ ?1array ] ?when ] change-names ; + +TUPLE: select names from where group-by order-by offset limit ; +CONSTRUCTOR: select ( names from -- obj ) ; +M: select normalize-fql ( select -- select ) + [ [ ?1array ] ?when ] change-names + [ [ ?1array ] ?when ] change-from + [ [ ?1array ] ?when ] change-group-by + [ [ ?1array ] ?when ] change-order-by ; + +TUPLE: where ; + +: expand-fql ( object1 -- object2 ) normalize-fql expand-fql* ; + +M: insert expand-fql* + [ fql-statement new ] dip + [ + { + [ "insert into " % into>> % ] + [ " (" % names>> ", " join % ")" % ] + [ " values (" % values>> length "?" ", " join % ");" % ] + [ values>> >>in ] + } cleave + ] "" make >>sql ; + +M: select expand-fql* + [ fql-statement new ] dip + [ + { + [ "select " % names>> ", " join % ] + [ " from " % from>> ", " join % ] + [ where>> [ " where " % [ expand-fql % ] when* ] when* ] + [ group-by>> [ " group by " % ", " join % ] when* ] + [ order-by>> [ " order by " % ", " join % ] when* ] + [ offset>> [ " offset " % # ] when* ] + [ limit>> [ " limit " % # ] when* ] + } cleave + ] "" make >>sql ; + + +M: fql-statement sql-command ( sql -- ) + sql>> sql-command ; + +M: fql-statement sql-query ( sql -- sequence ) + sql>> sql-query ; + +M: fql-statement sql-bind-command ( fql-statement -- ) + [ in>> ] [ sql>> ] bi sql-bind-command* ; + +M: fql-statement sql-bind-query ( fql-statement -- out-sequence ) + [ in>> ] [ sql>> ] bi sql-bind-query* ; + +M: fql-statement sql-bind-typed-command ( string -- ) + [ in>> ] [ sql>> ] bi sql-bind-typed-command* ; + +M: fql-statement sql-bind-typed-query ( string -- out-sequence ) + [ in>> ] [ sql>> ] bi sql-bind-typed-query* ; diff --git a/extra/db2/sqlite/lib/lib.factor b/extra/db2/sqlite/lib/lib.factor index f8503ee90f..261a2d42f3 100644 --- a/extra/db2/sqlite/lib/lib.factor +++ b/extra/db2/sqlite/lib/lib.factor @@ -1,16 +1,12 @@ ! Copyright (C) 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types arrays calendar.format -combinators db2.connections db2.sqlite.ffi db2.errors +combinators db2.connections db2.errors db2.result-sets +db2.sqlite.errors db2.sqlite.ffi db2.sqlite.result-sets io.backend io.encodings.string io.encodings.utf8 kernel math -namespaces present sequences serialize urls db2.sqlite.errors ; +namespaces present sequences serialize urls ; IN: db2.sqlite.lib -: ?when ( object quot -- object' ) dupd when ; inline - -: assoc-with ( object sequence quot -- obj curry ) - swapd [ [ -rot ] dip call ] 2curry ; inline - : sqlite-check-result ( n -- ) { { SQLITE_OK [ ] } diff --git a/extra/db2/statements/statements-tests.factor b/extra/db2/statements/statements-tests.factor index ed4b7babb8..56c73211c9 100644 --- a/extra/db2/statements/statements-tests.factor +++ b/extra/db2/statements/statements-tests.factor @@ -7,8 +7,7 @@ IN: db2.statements.tests { 1 0 } [ [ drop ] statement-each ] must-infer-as { 1 1 } [ [ ] statement-map ] must-infer-as - -: test-sql-command ( -- ) +: create-computer-table ( -- ) [ "drop table computer;" sql-command ] ignore-errors [ "drop table computer;" sql-command ] @@ -17,7 +16,11 @@ IN: db2.statements.tests [ ] [ "create table computer(name varchar, os varchar);" sql-command - ] unit-test + ] unit-test ; + + +: test-sql-command ( -- ) + create-computer-table [ ] [ "insert into computer (name, os) values('rocky', 'mac');" @@ -38,17 +41,17 @@ IN: db2.statements.tests [ ] [ { "clubber" "windows" } "insert into computer (name, os) values(?, ?);" - sql-bind-command + sql-bind-command* ] unit-test [ { { "windows" } } ] [ { "clubber" } - "select os from computer where name = ?;" sql-bind-query + "select os from computer where name = ?;" sql-bind-query* ] unit-test [ { { "windows" } } ] [ { { VARCHAR "clubber" } } - "select os from computer where name = ?;" sql-bind-typed-query + "select os from computer where name = ?;" sql-bind-typed-query* ] unit-test [ ] [ @@ -57,7 +60,7 @@ IN: db2.statements.tests { VARCHAR "windows" } } "insert into computer (name, os) values(?, ?);" - sql-bind-typed-command + sql-bind-typed-command* ] unit-test diff --git a/extra/db2/utils/authors.txt b/extra/db2/utils/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/db2/utils/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/db2/utils/utils.factor b/extra/db2/utils/utils.factor new file mode 100644 index 0000000000..2f5c9a277a --- /dev/null +++ b/extra/db2/utils/utils.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel ; +IN: db2.utils + +: ?when ( object quot -- object' ) dupd when ; inline + +: assoc-with ( object sequence quot -- obj curry ) + swapd [ [ -rot ] dip call ] 2curry ; inline From 7ab58fa3b3f4752e14e0b4f19b5f3697edfd0f01 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 13 Apr 2009 19:53:53 -0500 Subject: [PATCH 13/98] add test for all features of select except where clauses --- extra/db2/fql/fql-tests.factor | 11 +++++++++++ extra/db2/fql/fql.factor | 2 -- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/extra/db2/fql/fql-tests.factor b/extra/db2/fql/fql-tests.factor index 6a6f782b1e..cb1bee24ca 100644 --- a/extra/db2/fql/fql-tests.factor +++ b/extra/db2/fql/fql-tests.factor @@ -21,6 +21,17 @@ IN: db2.fql.tests expand-fql sql>> ] unit-test + [ "select name, os from computer group by os order by lol offset 100 limit 3" ] + [ + select new + { "name" "os" } >>names + "computer" >>from + "os" >>group-by + "lol" >>order-by + 100 >>offset + 3 >>limit + expand-fql sql>> + ] unit-test ; diff --git a/extra/db2/fql/fql.factor b/extra/db2/fql/fql.factor index 78abc5ee0b..222135606e 100644 --- a/extra/db2/fql/fql.factor +++ b/extra/db2/fql/fql.factor @@ -12,11 +12,9 @@ GENERIC: normalize-fql ( object -- sequence/fql-statement ) ! M: object normalize-fql ; - : ?1array ( obj -- array ) dup string? [ 1array ] when ; inline - TUPLE: insert into names values ; CONSTRUCTOR: insert ( into names values -- obj ) ; M: insert normalize-fql ( insert -- insert ) From 447a55418c0740ce9566a0c273dde3a88b280167 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 13 Apr 2009 20:26:48 -0500 Subject: [PATCH 14/98] add update, delete to fql --- extra/db2/fql/fql-tests.factor | 20 ++++++++++++++++ extra/db2/fql/fql.factor | 44 ++++++++++++++++++++++++++++++++-- 2 files changed, 62 insertions(+), 2 deletions(-) diff --git a/extra/db2/fql/fql-tests.factor b/extra/db2/fql/fql-tests.factor index cb1bee24ca..ca7b46b283 100644 --- a/extra/db2/fql/fql-tests.factor +++ b/extra/db2/fql/fql-tests.factor @@ -33,6 +33,26 @@ IN: db2.fql.tests expand-fql sql>> ] unit-test + [ "delete from computer order by omg limit 3" ] + [ + delete new + "computer" >>tables + "omg" >>order-by + 3 >>limit + expand-fql sql>> + ] unit-test + + [ "update computer set name = oscar order by omg limit 3" ] + [ + update new + "computer" >>tables + "name" >>keys + "oscar" >>values + "omg" >>order-by + 3 >>limit + expand-fql sql>> + ] unit-test + ; [ test-fql ] test-dbs diff --git a/extra/db2/fql/fql.factor b/extra/db2/fql/fql.factor index 222135606e..b71258c9d2 100644 --- a/extra/db2/fql/fql.factor +++ b/extra/db2/fql/fql.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators constructors db2 db2.private db2.sqlite.lib db2.statements db2.utils destructors -kernel make math.parser sequences strings ; +kernel make math.parser sequences strings assocs ; IN: db2.fql TUPLE: fql-statement sql in out ; @@ -20,6 +20,20 @@ CONSTRUCTOR: insert ( into names values -- obj ) ; M: insert normalize-fql ( insert -- insert ) [ [ ?1array ] ?when ] change-names ; +TUPLE: update tables keys values where order-by limit ; +CONSTRUCTOR: update ( tables keys values where -- obj ) ; +M: update normalize-fql ( insert -- insert ) + [ [ ?1array ] ?when ] change-tables + [ [ ?1array ] ?when ] change-keys + [ [ ?1array ] ?when ] change-values + [ [ ?1array ] ?when ] change-order-by ; + +TUPLE: delete tables where order-by limit ; +CONSTRUCTOR: delete ( tables keys values where -- obj ) ; +M: delete normalize-fql ( insert -- insert ) + [ [ ?1array ] ?when ] change-tables + [ [ ?1array ] ?when ] change-order-by ; + TUPLE: select names from where group-by order-by offset limit ; CONSTRUCTOR: select ( names from -- obj ) ; M: select normalize-fql ( select -- select ) @@ -43,6 +57,33 @@ M: insert expand-fql* } cleave ] "" make >>sql ; +M: update expand-fql* + [ fql-statement new ] dip + [ + { + [ "update " % tables>> ", " join % ] + [ + " set " % [ keys>> ] [ values>> ] bi + zip [ ", " % ] [ first2 [ % ] dip " = " % % ] interleave + ] + ! [ " " % from>> ", " join % ] + [ where>> [ " where " % [ expand-fql % ] when* ] when* ] + [ order-by>> [ " order by " % ", " join % ] when* ] + [ limit>> [ " limit " % # ] when* ] + } cleave + ] "" make >>sql ; + +M: delete expand-fql* + [ fql-statement new ] dip + [ + { + [ "delete from " % tables>> ", " join % ] + [ where>> [ " where " % [ expand-fql % ] when* ] when* ] + [ order-by>> [ " order by " % ", " join % ] when* ] + [ limit>> [ " limit " % # ] when* ] + } cleave + ] "" make >>sql ; + M: select expand-fql* [ fql-statement new ] dip [ @@ -57,7 +98,6 @@ M: select expand-fql* } cleave ] "" make >>sql ; - M: fql-statement sql-command ( sql -- ) sql>> sql-command ; From 7fcf5d55623a8dff41ae486e6fa152bcb7c11064 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 13 Apr 2009 20:50:32 -0500 Subject: [PATCH 15/98] remove check for GLU from factor.sh --- build-support/factor.sh | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index ad64c541fe..e3c56b13c8 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -139,7 +139,6 @@ check_library_exists() { } check_X11_libraries() { - check_library_exists GLU check_library_exists GL check_library_exists X11 check_library_exists pango-1.0 @@ -491,7 +490,7 @@ make_boot_image() { } install_build_system_apt() { - sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make + sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev wget git-core git-doc rlwrap gcc make check_ret sudo } From 0f4711abe3e48cc7c41f383be3ec1b6de4a9c964 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 13 Apr 2009 21:41:01 -0500 Subject: [PATCH 16/98] support AND and OR for where slot --- extra/db2/fql/fql-tests.factor | 18 +++++++++-- extra/db2/fql/fql.factor | 57 ++++++++++++++++++++++------------ extra/db2/utils/utils.factor | 2 ++ 3 files changed, 56 insertions(+), 21 deletions(-) diff --git a/extra/db2/fql/fql-tests.factor b/extra/db2/fql/fql-tests.factor index ca7b46b283..84698c09c2 100644 --- a/extra/db2/fql/fql-tests.factor +++ b/extra/db2/fql/fql-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors db2 db2.fql db2.statements.tests db2.tester -kernel tools.test ; +USING: accessors db2 db2.statements.tests db2.tester +kernel tools.test db2.fql ; IN: db2.fql.tests : test-fql ( -- ) @@ -33,6 +33,20 @@ IN: db2.fql.tests expand-fql sql>> ] unit-test + [ + "select name, os from computer where (hmm > 1 or foo is NULL) group by os order by lol offset 100 limit 3" + ] [ + select new + { "name" "os" } >>names + "computer" >>from + T{ or f { "hmm > 1" "foo is NULL" } } >>where + "os" >>group-by + "lol" >>order-by + 100 >>offset + 3 >>limit + expand-fql sql>> + ] unit-test + [ "delete from computer order by omg limit 3" ] [ delete new diff --git a/extra/db2/fql/fql.factor b/extra/db2/fql/fql.factor index b71258c9d2..e286e56a81 100644 --- a/extra/db2/fql/fql.factor +++ b/extra/db2/fql/fql.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators constructors db2 db2.private db2.sqlite.lib db2.statements db2.utils destructors -kernel make math.parser sequences strings assocs ; +kernel make math.parser sequences strings assocs db2.utils ; IN: db2.fql TUPLE: fql-statement sql in out ; @@ -12,40 +12,59 @@ GENERIC: normalize-fql ( object -- sequence/fql-statement ) ! M: object normalize-fql ; -: ?1array ( obj -- array ) - dup string? [ 1array ] when ; inline - TUPLE: insert into names values ; CONSTRUCTOR: insert ( into names values -- obj ) ; M: insert normalize-fql ( insert -- insert ) - [ [ ?1array ] ?when ] change-names ; + [ ??1array ] change-names ; TUPLE: update tables keys values where order-by limit ; CONSTRUCTOR: update ( tables keys values where -- obj ) ; M: update normalize-fql ( insert -- insert ) - [ [ ?1array ] ?when ] change-tables - [ [ ?1array ] ?when ] change-keys - [ [ ?1array ] ?when ] change-values - [ [ ?1array ] ?when ] change-order-by ; + [ ??1array ] change-tables + [ ??1array ] change-keys + [ ??1array ] change-values + [ ??1array ] change-order-by ; TUPLE: delete tables where order-by limit ; CONSTRUCTOR: delete ( tables keys values where -- obj ) ; M: delete normalize-fql ( insert -- insert ) - [ [ ?1array ] ?when ] change-tables - [ [ ?1array ] ?when ] change-order-by ; + [ ??1array ] change-tables + [ ??1array ] change-order-by ; TUPLE: select names from where group-by order-by offset limit ; CONSTRUCTOR: select ( names from -- obj ) ; M: select normalize-fql ( select -- select ) - [ [ ?1array ] ?when ] change-names - [ [ ?1array ] ?when ] change-from - [ [ ?1array ] ?when ] change-group-by - [ [ ?1array ] ?when ] change-order-by ; + [ ??1array ] change-names + [ ??1array ] change-from + [ ??1array ] change-group-by + [ ??1array ] change-order-by ; -TUPLE: where ; +! TUPLE: where sequence ; +! M: where normalize-fql ( where -- where ) + ! [ ??1array ] change-sequence ; + +TUPLE: and sequence ; + +TUPLE: or sequence ; : expand-fql ( object1 -- object2 ) normalize-fql expand-fql* ; +M: or expand-fql* ( obj -- string ) + [ + sequence>> "(" % + [ " or " % ] [ expand-fql* % ] interleave + ")" % + ] "" make ; + +M: and expand-fql* ( obj -- string ) + [ + sequence>> "(" % + [ " and " % ] [ expand-fql* % ] interleave + ")" % + ] "" make ; + +M: string expand-fql* ( string -- string ) ; + M: insert expand-fql* [ fql-statement new ] dip [ @@ -67,7 +86,7 @@ M: update expand-fql* zip [ ", " % ] [ first2 [ % ] dip " = " % % ] interleave ] ! [ " " % from>> ", " join % ] - [ where>> [ " where " % [ expand-fql % ] when* ] when* ] + [ where>> [ " where " % expand-fql* % ] when* ] [ order-by>> [ " order by " % ", " join % ] when* ] [ limit>> [ " limit " % # ] when* ] } cleave @@ -78,7 +97,7 @@ M: delete expand-fql* [ { [ "delete from " % tables>> ", " join % ] - [ where>> [ " where " % [ expand-fql % ] when* ] when* ] + [ where>> [ " where " % expand-fql* % ] when* ] [ order-by>> [ " order by " % ", " join % ] when* ] [ limit>> [ " limit " % # ] when* ] } cleave @@ -90,7 +109,7 @@ M: select expand-fql* { [ "select " % names>> ", " join % ] [ " from " % from>> ", " join % ] - [ where>> [ " where " % [ expand-fql % ] when* ] when* ] + [ where>> [ " where " % expand-fql* % ] when* ] [ group-by>> [ " group by " % ", " join % ] when* ] [ order-by>> [ " order by " % ", " join % ] when* ] [ offset>> [ " offset " % # ] when* ] diff --git a/extra/db2/utils/utils.factor b/extra/db2/utils/utils.factor index 2f5c9a277a..c9b009e917 100644 --- a/extra/db2/utils/utils.factor +++ b/extra/db2/utils/utils.factor @@ -4,6 +4,8 @@ USING: kernel ; IN: db2.utils : ?when ( object quot -- object' ) dupd when ; inline +: ?1array ( obj -- array ) dup string? [ 1array ] when ; inline +: ??1array ( obj -- array/f ) [ ?1array ] ?when ; inline : assoc-with ( object sequence quot -- obj curry ) swapd [ [ -rot ] dip call ] 2curry ; inline From 14948008405aaaa72fe44e645d7168a03d08d309 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 14 Apr 2009 11:26:54 -0500 Subject: [PATCH 17/98] add introspection vocab to examine tables --- extra/db2/db2.factor | 7 ---- extra/db2/introspection/authors.txt | 1 + extra/db2/introspection/introspection.factor | 34 +++++++++++++++++ .../db2/sqlite/connections/connections.factor | 5 --- extra/db2/sqlite/introspection/authors.txt | 1 + .../introspection/introspection-tests.factor | 38 +++++++++++++++++++ .../sqlite/introspection/introspection.factor | 16 ++++++++ extra/db2/sqlite/statements/statements.factor | 2 +- extra/db2/sqlite/types/types.factor | 15 ++++++-- extra/db2/utils/utils.factor | 5 ++- 10 files changed, 107 insertions(+), 17 deletions(-) create mode 100644 extra/db2/introspection/authors.txt create mode 100644 extra/db2/introspection/introspection.factor create mode 100644 extra/db2/sqlite/introspection/authors.txt create mode 100644 extra/db2/sqlite/introspection/introspection-tests.factor create mode 100644 extra/db2/sqlite/introspection/introspection.factor diff --git a/extra/db2/db2.factor b/extra/db2/db2.factor index 4687a6329f..bda3d7ad70 100644 --- a/extra/db2/db2.factor +++ b/extra/db2/db2.factor @@ -54,10 +54,3 @@ M: sequence sql-bind-command* [ sql-bind-command* ] with each ; M: sequence sql-bind-query* [ sql-bind-query* ] with map ; M: sequence sql-bind-typed-command* [ sql-bind-typed-command* ] with each ; M: sequence sql-bind-typed-query* [ sql-bind-typed-query* ] with map ; - -! M: string sql-command [ sql-command ] each ; -! M: string sql-query [ sql-query ] map ; -! M: string sql-bind-command* sql-bind-command* ; -! M: string sql-bind-query* sql-bind-query* ; -! M: string sql-bind-typed-command sql-bind-typed-command* ; -! M: string sql-bind-typed-query sql-bind-typed-query* ; diff --git a/extra/db2/introspection/authors.txt b/extra/db2/introspection/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/db2/introspection/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/db2/introspection/introspection.factor b/extra/db2/introspection/introspection.factor new file mode 100644 index 0000000000..8ab08876aa --- /dev/null +++ b/extra/db2/introspection/introspection.factor @@ -0,0 +1,34 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators constructors db2.connections +db2.sqlite.types kernel sequence-parser sequences splitting ; +IN: db2.introspection + +TUPLE: table-schema table columns ; +CONSTRUCTOR: table-schema ( table columns -- table-schema ) ; + +TUPLE: column name type modifiers ; +CONSTRUCTOR: column ( name type modifiers -- column ) ; + +HOOK: query-table-schema* db-connection ( name -- table-schema ) +HOOK: parse-create-statement db-connection ( name -- table-schema ) + +: parse-column ( string -- column ) + skip-whitespace + [ " " take-until-sequence ] + [ take-token sqlite-type>fql-type ] + [ take-rest ] tri ; + +: parse-columns ( string -- seq ) + "," split [ parse-column ] map ; + +M: object parse-create-statement ( string -- table-schema ) + { + [ "CREATE TABLE " take-sequence* ] + [ "(" take-until-sequence ] + [ "(" take-sequence* ] + [ take-rest [ CHAR: ) = ] trim-tail parse-columns ] + } cleave ; + +: query-table-schema ( name -- table-schema ) + query-table-schema* [ parse-create-statement ] map ; diff --git a/extra/db2/sqlite/connections/connections.factor b/extra/db2/sqlite/connections/connections.factor index b99603f4ef..ae96e58d28 100644 --- a/extra/db2/sqlite/connections/connections.factor +++ b/extra/db2/sqlite/connections/connections.factor @@ -4,11 +4,6 @@ USING: accessors combinators db2.connections db2.sqlite db2.sqlite.errors db2.sqlite.lib kernel db2.errors ; IN: db2.sqlite.connections -TUPLE: sqlite-db-connection < db-connection ; - -: ( handle -- db-connection ) - sqlite-db-connection new-db-connection ; - M: sqlite-db db-open ( db -- db-connection ) path>> sqlite-open ; diff --git a/extra/db2/sqlite/introspection/authors.txt b/extra/db2/sqlite/introspection/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/db2/sqlite/introspection/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/db2/sqlite/introspection/introspection-tests.factor b/extra/db2/sqlite/introspection/introspection-tests.factor new file mode 100644 index 0000000000..d8ebc4d60e --- /dev/null +++ b/extra/db2/sqlite/introspection/introspection-tests.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: db2.connections db2.introspection +db2.sqlite.introspection db2.tester db2.types tools.test ; +IN: db2.sqlite.introspection.tests + + +: test-sqlite-introspection ( -- ) + [ + { + T{ table-schema + { table "computer" } + { columns + { + T{ column + { name "name" } + { type VARCHAR } + { modifiers "" } + } + T{ column + { name "os" } + { type VARCHAR } + { modifiers "" } + } + } + } + } + } + ] [ + + sqlite-test-db [ + "computer" query-table-schema + ] with-db + ] unit-test + + ; + +[ test-sqlite-introspection ] test-sqlite diff --git a/extra/db2/sqlite/introspection/introspection.factor b/extra/db2/sqlite/introspection/introspection.factor new file mode 100644 index 0000000000..41def2c558 --- /dev/null +++ b/extra/db2/sqlite/introspection/introspection.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays db2 db2.introspection db2.sqlite multiline +sequences ; +IN: db2.sqlite.introspection + +M: sqlite-db-connection query-table-schema* + 1array +<" +SELECT sql FROM + (SELECT * FROM sqlite_master UNION ALL + SELECT * FROM sqlite_temp_master) +WHERE type!='meta' and tbl_name = ? +ORDER BY tbl_name, type DESC, name +"> + sql-bind-query* first ; diff --git a/extra/db2/sqlite/statements/statements.factor b/extra/db2/sqlite/statements/statements.factor index 64ce390308..0033ad06e1 100644 --- a/extra/db2/sqlite/statements/statements.factor +++ b/extra/db2/sqlite/statements/statements.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors db2.connections db2.sqlite.connections db2.sqlite.ffi db2.sqlite.lib db2.statements destructors kernel -namespaces ; +namespaces db2.sqlite ; IN: db2.sqlite.statements TUPLE: sqlite-statement < statement ; diff --git a/extra/db2/sqlite/types/types.factor b/extra/db2/sqlite/types/types.factor index 7124568fbe..c8df3b2272 100644 --- a/extra/db2/sqlite/types/types.factor +++ b/extra/db2/sqlite/types/types.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays calendar.format combinators db2.types -db2.sqlite.ffi db2.sqlite.lib math fry -kernel present sequences serialize urls ; +USING: accessors arrays calendar.format combinators +db2.sqlite.ffi db2.sqlite.lib db2.sqlite.statements +db2.statements db2.types db2.utils fry kernel math present +sequences serialize urls ; IN: db2.sqlite.types : (bind-sqlite-type) ( handle key value type -- ) @@ -93,3 +94,11 @@ M: sqlite-statement bind-typed-sequence ( sequence statement -- ) handle>> '[ [ _ ] 2dip 1+ swap first2 swap bind-next-sqlite-type ] each-index ; + +ERROR: no-fql-type type ; + +: sqlite-type>fql-type ( string -- type ) + { + { "varchar" [ VARCHAR ] } + [ no-fql-type ] + } case ; diff --git a/extra/db2/utils/utils.factor b/extra/db2/utils/utils.factor index c9b009e917..71fa9bc5ae 100644 --- a/extra/db2/utils/utils.factor +++ b/extra/db2/utils/utils.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel ; +USING: arrays kernel math math.parser strings ; IN: db2.utils : ?when ( object quot -- object' ) dupd when ; inline @@ -9,3 +9,6 @@ IN: db2.utils : assoc-with ( object sequence quot -- obj curry ) swapd [ [ -rot ] dip call ] 2curry ; inline + +: ?number>string ( n/string -- string ) + dup number? [ number>string ] when ; From 6f1d15e84c1eaaa917f61a61ed5bab0cdaf22393 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 14 Apr 2009 16:14:40 -0500 Subject: [PATCH 18/98] refactoring the db protocol, remove fql-statements --- extra/db2/db2.factor | 43 ++++++++++---------- extra/db2/fql/fql.factor | 32 +++------------ extra/db2/result-sets/result-sets.factor | 2 +- extra/db2/sqlite/types/types.factor | 8 ++-- extra/db2/statements/statements-tests.factor | 21 ++++++---- extra/db2/statements/statements.factor | 8 +++- 6 files changed, 51 insertions(+), 63 deletions(-) diff --git a/extra/db2/db2.factor b/extra/db2/db2.factor index bda3d7ad70..e67cb8d200 100644 --- a/extra/db2/db2.factor +++ b/extra/db2/db2.factor @@ -8,49 +8,50 @@ IN: db2 GENERIC: sql-command ( object -- ) GENERIC: sql-query ( object -- sequence ) -GENERIC: sql-bind-command* ( sequence object -- ) -GENERIC: sql-bind-query* ( sequence object -- sequence ) -GENERIC: sql-bind-typed-command* ( sequence object -- ) -GENERIC: sql-bind-typed-query* ( sequence object -- sequence ) - GENERIC: sql-bind-command ( object -- ) GENERIC: sql-bind-query ( object -- sequence ) GENERIC: sql-bind-typed-command ( object -- ) GENERIC: sql-bind-typed-query ( object -- sequence ) -M: string sql-command ( sql -- ) - f f [ execute-statement ] with-disposal ; +M: string sql-command ( string -- ) + f f sql-command ; -M: string sql-query ( sql -- sequence ) - f f [ statement>result-sequence ] with-disposal ; +M: string sql-query ( string -- sequence ) + f f sql-query ; -M: string sql-bind-command* ( sequence string -- ) - f f [ +M: statement sql-command ( statement -- ) + [ execute-statement ] with-disposal ; + +M: statement sql-query ( statement -- sequence ) + [ statement>result-sequence ] with-disposal ; + +M: statement sql-bind-command ( statement -- ) + [ prepare-statement [ bind-sequence ] [ statement>result-set drop ] bi ] with-disposal ; -M: string sql-bind-query* ( in-sequence string -- out-sequence ) - f f [ +M: statement sql-bind-query ( statement -- sequence ) + [ prepare-statement [ bind-sequence ] [ statement>result-sequence ] bi ] with-disposal ; -M: string sql-bind-typed-command* ( in-sequence string -- ) - f f [ +M: statement sql-bind-typed-command ( statement -- ) + [ prepare-statement [ bind-typed-sequence ] [ statement>result-set drop ] bi ] with-disposal ; -M: string sql-bind-typed-query* ( in-sequence string -- out-sequence ) - f f [ +M: statement sql-bind-typed-query ( statement -- sequence ) + [ prepare-statement [ bind-typed-sequence ] [ statement>result-sequence ] bi ] with-disposal ; M: sequence sql-command [ sql-command ] each ; M: sequence sql-query [ sql-query ] map ; -M: sequence sql-bind-command* [ sql-bind-command* ] with each ; -M: sequence sql-bind-query* [ sql-bind-query* ] with map ; -M: sequence sql-bind-typed-command* [ sql-bind-typed-command* ] with each ; -M: sequence sql-bind-typed-query* [ sql-bind-typed-query* ] with map ; +M: sequence sql-bind-command [ sql-bind-command ] each ; +M: sequence sql-bind-query [ sql-bind-query ] map ; +M: sequence sql-bind-typed-command [ sql-bind-typed-command ] each ; +M: sequence sql-bind-typed-query [ sql-bind-typed-query ] map ; diff --git a/extra/db2/fql/fql.factor b/extra/db2/fql/fql.factor index e286e56a81..0896899b01 100644 --- a/extra/db2/fql/fql.factor +++ b/extra/db2/fql/fql.factor @@ -5,10 +5,8 @@ db2.private db2.sqlite.lib db2.statements db2.utils destructors kernel make math.parser sequences strings assocs db2.utils ; IN: db2.fql -TUPLE: fql-statement sql in out ; - -GENERIC: expand-fql* ( object -- sequence/fql-statement ) -GENERIC: normalize-fql ( object -- sequence/fql-statement ) +GENERIC: expand-fql* ( object -- sequence/statement ) +GENERIC: normalize-fql ( object -- sequence/statement ) ! M: object normalize-fql ; @@ -66,7 +64,7 @@ M: and expand-fql* ( obj -- string ) M: string expand-fql* ( string -- string ) ; M: insert expand-fql* - [ fql-statement new ] dip + [ statement new ] dip [ { [ "insert into " % into>> % ] @@ -77,7 +75,7 @@ M: insert expand-fql* ] "" make >>sql ; M: update expand-fql* - [ fql-statement new ] dip + [ statement new ] dip [ { [ "update " % tables>> ", " join % ] @@ -93,7 +91,7 @@ M: update expand-fql* ] "" make >>sql ; M: delete expand-fql* - [ fql-statement new ] dip + [ statement new ] dip [ { [ "delete from " % tables>> ", " join % ] @@ -104,7 +102,7 @@ M: delete expand-fql* ] "" make >>sql ; M: select expand-fql* - [ fql-statement new ] dip + [ statement new ] dip [ { [ "select " % names>> ", " join % ] @@ -116,21 +114,3 @@ M: select expand-fql* [ limit>> [ " limit " % # ] when* ] } cleave ] "" make >>sql ; - -M: fql-statement sql-command ( sql -- ) - sql>> sql-command ; - -M: fql-statement sql-query ( sql -- sequence ) - sql>> sql-query ; - -M: fql-statement sql-bind-command ( fql-statement -- ) - [ in>> ] [ sql>> ] bi sql-bind-command* ; - -M: fql-statement sql-bind-query ( fql-statement -- out-sequence ) - [ in>> ] [ sql>> ] bi sql-bind-query* ; - -M: fql-statement sql-bind-typed-command ( string -- ) - [ in>> ] [ sql>> ] bi sql-bind-typed-command* ; - -M: fql-statement sql-bind-typed-query ( string -- out-sequence ) - [ in>> ] [ sql>> ] bi sql-bind-typed-query* ; diff --git a/extra/db2/result-sets/result-sets.factor b/extra/db2/result-sets/result-sets.factor index 6f69c26ab2..5bf148d4be 100644 --- a/extra/db2/result-sets/result-sets.factor +++ b/extra/db2/result-sets/result-sets.factor @@ -29,4 +29,4 @@ GENERIC# column-typed 1 ( result-set column -- sql ) dup #columns [ column ] with map ; : sql-row-typed ( result-set -- seq ) - dup #columns [ column-typed ] with map ; + dup #columns [ B column-typed ] with map ; diff --git a/extra/db2/sqlite/types/types.factor b/extra/db2/sqlite/types/types.factor index c8df3b2272..d2047c1aeb 100644 --- a/extra/db2/sqlite/types/types.factor +++ b/extra/db2/sqlite/types/types.factor @@ -85,13 +85,13 @@ IN: db2.sqlite.types [ no-sql-type ] } case ; -M: sqlite-statement bind-sequence ( sequence statement -- ) - handle>> '[ +M: sqlite-statement bind-sequence ( statement -- ) + [ in>> ] [ handle>> ] bi '[ [ _ ] 2dip 1+ swap sqlite-bind-text ] each-index ; -M: sqlite-statement bind-typed-sequence ( sequence statement -- ) - handle>> '[ +M: sqlite-statement bind-typed-sequence ( statement -- ) + [ in>> ] [ handle>> ] bi '[ [ _ ] 2dip 1+ swap first2 swap bind-next-sqlite-type ] each-index ; diff --git a/extra/db2/statements/statements-tests.factor b/extra/db2/statements/statements-tests.factor index 56c73211c9..6a4b774713 100644 --- a/extra/db2/statements/statements-tests.factor +++ b/extra/db2/statements/statements-tests.factor @@ -29,7 +29,8 @@ IN: db2.statements.tests [ { { "rocky" "mac" } } ] [ - "select name, os from computer;" sql-query + "select name, os from computer;" + f f sql-query ] unit-test [ "insert into" sql-command ] @@ -39,28 +40,30 @@ IN: db2.statements.tests [ sql-syntax-error? ] must-fail-with [ ] [ - { "clubber" "windows" } "insert into computer (name, os) values(?, ?);" - sql-bind-command* + { "clubber" "windows" } + f + sql-bind-command ] unit-test [ { { "windows" } } ] [ - { "clubber" } - "select os from computer where name = ?;" sql-bind-query* + "select os from computer where name = ?;" + { "clubber" } f sql-bind-query ] unit-test [ { { "windows" } } ] [ + "select os from computer where name = ?;" { { VARCHAR "clubber" } } - "select os from computer where name = ?;" sql-bind-typed-query* + f sql-bind-typed-query ] unit-test [ ] [ + "insert into computer (name, os) values(?, ?);" { { VARCHAR "clubber" } { VARCHAR "windows" } - } - "insert into computer (name, os) values(?, ?);" - sql-bind-typed-command* + } f + sql-bind-typed-command ] unit-test diff --git a/extra/db2/statements/statements.factor b/extra/db2/statements/statements.factor index 989391473d..929b303d4b 100644 --- a/extra/db2/statements/statements.factor +++ b/extra/db2/statements/statements.factor @@ -16,8 +16,8 @@ HOOK: db-connection ( sql in out -- statement ) GENERIC: statement>result-set* ( statement -- result-set ) GENERIC: execute-statement* ( statement type -- ) GENERIC: prepare-statement* ( statement -- statement' ) -GENERIC: bind-sequence ( sequence statement -- ) -GENERIC: bind-typed-sequence ( sequence statement -- ) +GENERIC: bind-sequence ( statement -- ) +GENERIC: bind-typed-sequence ( statement -- ) : statement>result-set ( statement -- result-set ) [ statement>result-set* ] @@ -47,3 +47,7 @@ M: object execute-statement* ( statement type -- ) : statement>result-sequence ( statement -- sequence ) statement>result-set [ [ sql-row ] statement-map ] with-disposal ; + +: statement>typed-result-sequence ( statement -- sequence ) + [ out>> ] [ statement>result-set ] bi + [ [ sql-row-typed ] with statement-map ] with-disposal ; From 1f004a11009e95b649ea981c0845c25c87ff91c3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 14 Apr 2009 17:10:16 -0500 Subject: [PATCH 19/98] support typed queries --- extra/db2/db2.factor | 23 ++++++++++++++++++- extra/db2/result-sets/result-sets.factor | 7 +++--- .../db2/sqlite/result-sets/result-sets.factor | 8 +++++-- extra/db2/statements/statements-tests.factor | 7 +++--- extra/db2/statements/statements.factor | 14 +++++------ 5 files changed, 43 insertions(+), 16 deletions(-) diff --git a/extra/db2/db2.factor b/extra/db2/db2.factor index e67cb8d200..b14ee969be 100644 --- a/extra/db2/db2.factor +++ b/extra/db2/db2.factor @@ -6,6 +6,15 @@ destructors fry kernel math namespaces sequences strings db2.sqlite.types ; IN: db2 +ERROR: no-in-types statement ; +ERROR: no-out-types statement ; + +: guard-in ( statement -- statement ) + dup in>> [ no-in-types ] unless ; + +: guard-out ( statement -- statement ) + dup out>> [ no-out-types ] unless ; + GENERIC: sql-command ( object -- ) GENERIC: sql-query ( object -- sequence ) GENERIC: sql-bind-command ( object -- ) @@ -27,26 +36,31 @@ M: statement sql-query ( statement -- sequence ) M: statement sql-bind-command ( statement -- ) [ + guard-in prepare-statement [ bind-sequence ] [ statement>result-set drop ] bi ] with-disposal ; M: statement sql-bind-query ( statement -- sequence ) [ + guard-in prepare-statement [ bind-sequence ] [ statement>result-sequence ] bi ] with-disposal ; M: statement sql-bind-typed-command ( statement -- ) [ + guard-in prepare-statement [ bind-typed-sequence ] [ statement>result-set drop ] bi ] with-disposal ; M: statement sql-bind-typed-query ( statement -- sequence ) [ + guard-in + guard-out prepare-statement - [ bind-typed-sequence ] [ statement>result-sequence ] bi + [ bind-typed-sequence ] [ statement>typed-result-sequence ] bi ] with-disposal ; M: sequence sql-command [ sql-command ] each ; @@ -55,3 +69,10 @@ M: sequence sql-bind-command [ sql-bind-command ] each ; M: sequence sql-bind-query [ sql-bind-query ] map ; M: sequence sql-bind-typed-command [ sql-bind-typed-command ] each ; M: sequence sql-bind-typed-query [ sql-bind-typed-query ] map ; + +M: integer sql-command throw ; +M: integer sql-query throw ; +M: integer sql-bind-command throw ; +M: integer sql-bind-query throw ; +M: integer sql-bind-typed-command throw ; +M: integer sql-bind-typed-query throw ; diff --git a/extra/db2/result-sets/result-sets.factor b/extra/db2/result-sets/result-sets.factor index 5bf148d4be..499808930a 100644 --- a/extra/db2/result-sets/result-sets.factor +++ b/extra/db2/result-sets/result-sets.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences combinators ; +USING: accessors kernel sequences combinators fry ; IN: db2.result-sets TUPLE: result-set sql in out handle n max ; @@ -10,7 +10,7 @@ GENERIC: #columns ( result-set -- n ) GENERIC: advance-row ( result-set -- ) GENERIC: more-rows? ( result-set -- ? ) GENERIC# column 1 ( result-set column -- obj ) -GENERIC# column-typed 1 ( result-set column -- sql ) +GENERIC# column-typed 2 ( result-set column type -- sql ) : init-result-set ( result-set -- result-set ) dup #rows >>max @@ -29,4 +29,5 @@ GENERIC# column-typed 1 ( result-set column -- sql ) dup #columns [ column ] with map ; : sql-row-typed ( result-set -- seq ) - dup #columns [ B column-typed ] with map ; + [ #columns ] [ out>> ] [ ] tri + '[ [ _ ] 2dip column-typed ] 2map ; diff --git a/extra/db2/sqlite/result-sets/result-sets.factor b/extra/db2/sqlite/result-sets/result-sets.factor index afc0c7bfc2..f3d677ed21 100644 --- a/extra/db2/sqlite/result-sets/result-sets.factor +++ b/extra/db2/sqlite/result-sets/result-sets.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors db2.result-sets db2.sqlite.statements -db2.statements kernel db2.sqlite.lib destructors ; +db2.statements kernel db2.sqlite.lib destructors +db2.sqlite.types ; IN: db2.sqlite.result-sets TUPLE: sqlite-result-set < result-set has-more? ; @@ -10,7 +11,7 @@ M: sqlite-result-set dispose f >>handle drop ; M: sqlite-statement statement>result-set* - sqlite-maybe-prepare >sqlite-result-set ; + prepare-statement >sqlite-result-set ; M: sqlite-result-set advance-row ( result-set -- ) dup handle>> sqlite-next >>has-more? drop ; @@ -23,3 +24,6 @@ M: sqlite-result-set #columns ( result-set -- n ) M: sqlite-result-set column ( result-set n -- obj ) [ handle>> ] [ sqlite-column ] bi* ; + +M: sqlite-result-set column-typed ( result-set n type -- obj ) + [ handle>> ] 2dip sqlite-type ; diff --git a/extra/db2/statements/statements-tests.factor b/extra/db2/statements/statements-tests.factor index 6a4b774713..d90e70ea70 100644 --- a/extra/db2/statements/statements-tests.factor +++ b/extra/db2/statements/statements-tests.factor @@ -4,8 +4,8 @@ USING: tools.test db2.statements kernel db2 db2.tester continuations db2.errors accessors db2.types ; IN: db2.statements.tests -{ 1 0 } [ [ drop ] statement-each ] must-infer-as -{ 1 1 } [ [ ] statement-map ] must-infer-as +{ 1 0 } [ [ drop ] result-set-each ] must-infer-as +{ 1 1 } [ [ ] result-set-map ] must-infer-as : create-computer-table ( -- ) [ "drop table computer;" sql-command ] ignore-errors @@ -54,7 +54,8 @@ IN: db2.statements.tests [ { { "windows" } } ] [ "select os from computer where name = ?;" { { VARCHAR "clubber" } } - f sql-bind-typed-query + { VARCHAR } + sql-bind-typed-query ] unit-test [ ] [ diff --git a/extra/db2/statements/statements.factor b/extra/db2/statements/statements.factor index 929b303d4b..9ddd74ded7 100644 --- a/extra/db2/statements/statements.factor +++ b/extra/db2/statements/statements.factor @@ -37,17 +37,17 @@ M: object execute-statement* ( statement type -- ) : prepare-statement ( statement -- statement ) dup handle>> [ prepare-statement* ] unless ; -: statement-each ( statement quot: ( statement -- ) -- ) +: result-set-each ( statement quot: ( statement -- ) -- ) over more-rows? - [ [ call ] 2keep over advance-row statement-each ] + [ [ call ] 2keep over advance-row result-set-each ] [ 2drop ] if ; inline recursive -: statement-map ( statement quot -- sequence ) - accumulator [ statement-each ] dip { } like ; inline +: result-set-map ( statement quot -- sequence ) + accumulator [ result-set-each ] dip { } like ; inline : statement>result-sequence ( statement -- sequence ) - statement>result-set [ [ sql-row ] statement-map ] with-disposal ; + statement>result-set [ [ sql-row ] result-set-map ] with-disposal ; : statement>typed-result-sequence ( statement -- sequence ) - [ out>> ] [ statement>result-set ] bi - [ [ sql-row-typed ] with statement-map ] with-disposal ; + statement>result-set + [ [ sql-row-typed ] result-set-map ] with-disposal ; From a3d25ed3222f554bee74f35d5df719c8065ba4f6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 14 Apr 2009 17:18:48 -0500 Subject: [PATCH 20/98] more tests --- extra/db2/statements/statements-tests.factor | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/extra/db2/statements/statements-tests.factor b/extra/db2/statements/statements-tests.factor index d90e70ea70..8a872293d9 100644 --- a/extra/db2/statements/statements-tests.factor +++ b/extra/db2/statements/statements-tests.factor @@ -14,7 +14,7 @@ IN: db2.statements.tests [ [ sql-table-missing? ] [ table>> "computer" = ] bi and ] must-fail-with [ ] [ - "create table computer(name varchar, os varchar);" + "create table computer(name varchar, os varchar, version integer);" sql-command ] unit-test ; @@ -40,8 +40,8 @@ IN: db2.statements.tests [ sql-syntax-error? ] must-fail-with [ ] [ - "insert into computer (name, os) values(?, ?);" - { "clubber" "windows" } + "insert into computer (name, os, version) values(?, ?, ?);" + { "clubber" "windows" "7" } f sql-bind-command ] unit-test @@ -51,23 +51,23 @@ IN: db2.statements.tests { "clubber" } f sql-bind-query ] unit-test - [ { { "windows" } } ] [ - "select os from computer where name = ?;" + [ { { "windows" 7 } } ] [ + "select os, version from computer where name = ?;" { { VARCHAR "clubber" } } - { VARCHAR } + { VARCHAR INTEGER } sql-bind-typed-query ] unit-test [ ] [ - "insert into computer (name, os) values(?, ?);" + "insert into computer (name, os, version) values(?, ?, ?);" { - { VARCHAR "clubber" } - { VARCHAR "windows" } + { VARCHAR "paulie" } + { VARCHAR "netbsd" } + { INTEGER 7 } } f sql-bind-typed-command ] unit-test - ; [ test-sql-command ] test-dbs From 8644c9854938dcb1efb1cd2c253cc0e06e308dd0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 14 Apr 2009 22:47:39 -0500 Subject: [PATCH 21/98] fix up tar --- extra/tar/tar.factor | 78 +++++++++++++++++++++++--------------------- 1 file changed, 41 insertions(+), 37 deletions(-) diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 37c022fe43..e83908b002 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -1,8 +1,10 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: combinators io io.files io.files.links io.directories io.pathnames io.streams.string kernel math math.parser continuations namespaces pack prettyprint sequences strings system tools.hexdump io.encodings.binary summary accessors -io.backend byte-arrays ; +io.backend byte-arrays io.streams.byte-array splitting ; IN: tar CONSTANT: zero-checksum 256 @@ -10,37 +12,35 @@ CONSTANT: block-size 512 TUPLE: tar-header name mode uid gid size mtime checksum typeflag linkname magic version uname gname devmajor devminor prefix ; + ERROR: checksum-error ; -SYMBOLS: base-dir filename ; +: trim-string ( seq -- newseq ) [ "\0 " member? ] trim ; -: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ; - -: read-c-string* ( n -- str/f ) +: read-c-string ( n -- str/f ) read [ zero? ] trim-tail [ f ] when-empty ; : read-tar-header ( -- obj ) \ tar-header new - 100 read-c-string* >>name - 8 read-c-string* tar-trim oct> >>mode - 8 read-c-string* tar-trim oct> >>uid - 8 read-c-string* tar-trim oct> >>gid - 12 read-c-string* tar-trim oct> >>size - 12 read-c-string* tar-trim oct> >>mtime - 8 read-c-string* tar-trim oct> >>checksum - read1 >>typeflag - 100 read-c-string* >>linkname - 6 read >>magic - 2 read >>version - 32 read-c-string* >>uname - 32 read-c-string* >>gname - 8 read tar-trim oct> >>devmajor - 8 read tar-trim oct> >>devminor - 155 read-c-string* >>prefix ; + 100 read-c-string >>name + 8 read-c-string trim-string oct> >>mode + 8 read-c-string trim-string oct> >>uid + 8 read-c-string trim-string oct> >>gid + 12 read-c-string trim-string oct> >>size + 12 read-c-string trim-string oct> >>mtime + 8 read-c-string trim-string oct> >>checksum + read1 >>typeflag + 100 read-c-string >>linkname + 6 read >>magic + 2 read >>version + 32 read-c-string >>uname + 32 read-c-string >>gname + 8 read trim-string oct> >>devmajor + 8 read trim-string oct> >>devminor + 155 read-c-string >>prefix ; -: header-checksum ( seq -- x ) - 148 cut-slice 8 tail-slice - [ sum ] bi@ + 256 + ; +: checksum-header ( seq -- n ) + 148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ; : read-data-blocks ( tar-header -- ) dup size>> 0 > [ @@ -60,29 +60,33 @@ SYMBOLS: base-dir filename ; ] if ; : parse-tar-header ( seq -- obj ) - [ header-checksum ] keep over zero-checksum = [ + [ checksum-header ] keep over zero-checksum = [ 2drop \ tar-header new 0 >>size 0 >>checksum ] [ - [ read-tar-header ] with-string-reader + binary [ read-tar-header ] with-byte-reader [ checksum>> = [ checksum-error ] unless ] keep ] if ; ERROR: unknown-typeflag ch ; M: unknown-typeflag summary ( obj -- str ) - ch>> 1string "Unknown typeflag: " prepend ; - -: tar-prepend-path ( path -- newpath ) - base-dir get prepend-path ; + ch>> "Unknown typeflag: " prefix ; : read/write-blocks ( tar-header path -- ) binary [ read-data-blocks ] with-file-writer ; +: prepend-current-directory ( path -- path' ) + current-directory get prepend-path ; + ! Normal file : typeflag-0 ( header -- ) - dup name>> tar-prepend-path read/write-blocks ; + dup name>> dup global_pax_header = [ + [ read-data-blocks ] with-string-writer drop + ] [ + prepend-current-directory read/write-blocks + ] if ; ! Hard link : typeflag-1 ( header -- ) unknown-typeflag ; @@ -99,7 +103,7 @@ M: unknown-typeflag summary ( obj -- str ) ! Directory : typeflag-5 ( header -- ) - name>> tar-prepend-path make-directories ; + name>> prepend-current-directory make-directories ; ! FIFO : typeflag-6 ( header -- ) unknown-typeflag ; @@ -139,7 +143,7 @@ M: unknown-typeflag summary ( obj -- str ) drop ; ! [ read-data-blocks ] keep ! >string [ zero? ] trim-tail filename set - ! filename get tar-prepend-path make-directories ; + ! filename get prepend-current-directory make-directories ; ! Multi volume continuation entry : typeflag-M ( header -- ) unknown-typeflag ; @@ -157,7 +161,7 @@ M: unknown-typeflag summary ( obj -- str ) : typeflag-X ( header -- ) unknown-typeflag ; : (parse-tar) ( -- ) - block-size read dup length 512 = [ + block-size read dup length block-size = [ parse-tar-header dup typeflag>> { @@ -189,7 +193,7 @@ M: unknown-typeflag summary ( obj -- str ) drop ] if ; -: parse-tar ( path -- ) - normalize-path dup parent-directory base-dir [ +: untar ( path -- ) + normalize-path [ ] [ parent-directory ] bi [ binary [ (parse-tar) ] with-file-reader - ] with-variable ; + ] with-directory ; From 34e945fd28cc4f2048eb84eb61acb8f4b734c78e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 14 Apr 2009 22:54:28 -0500 Subject: [PATCH 22/98] use prefix correctly --- extra/tar/tar.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index e83908b002..50d3f25593 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -71,8 +71,9 @@ ERROR: checksum-error ; ] if ; ERROR: unknown-typeflag ch ; + M: unknown-typeflag summary ( obj -- str ) - ch>> "Unknown typeflag: " prefix ; + ch>> [ "Unknown typeflag: " ] dip prefix ; : read/write-blocks ( tar-header path -- ) binary [ read-data-blocks ] with-file-writer ; From 2ca8e69348b838e81bc7b2ad0b5326d00ded749e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 14 Apr 2009 22:59:45 -0500 Subject: [PATCH 23/98] fix handling of global_pax_header --- extra/tar/tar.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 50d3f25593..297157c08b 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -83,8 +83,8 @@ M: unknown-typeflag summary ( obj -- str ) ! Normal file : typeflag-0 ( header -- ) - dup name>> dup global_pax_header = [ - [ read-data-blocks ] with-string-writer drop + dup name>> dup "global_pax_header" = [ + drop [ read-data-blocks ] with-string-writer drop ] [ prepend-current-directory read/write-blocks ] if ; From 840675e242b88353a43e8fdeb1abdcaeb62a69a7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 15 Apr 2009 18:32:07 -0500 Subject: [PATCH 24/98] fix circularity --- extra/db2/sqlite/lib/lib.factor | 8 ++------ extra/db2/sqlite/result-sets/result-sets.factor | 3 ++- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/extra/db2/sqlite/lib/lib.factor b/extra/db2/sqlite/lib/lib.factor index 261a2d42f3..e366305fcd 100644 --- a/extra/db2/sqlite/lib/lib.factor +++ b/extra/db2/sqlite/lib/lib.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types arrays calendar.format -combinators db2.connections db2.errors db2.result-sets -db2.sqlite.errors db2.sqlite.ffi db2.sqlite.result-sets +combinators db2.sqlite.errors io.backend io.encodings.string io.encodings.utf8 kernel math -namespaces present sequences serialize urls ; +namespaces present sequences serialize urls db2.sqlite.ffi ; IN: db2.sqlite.lib : sqlite-check-result ( n -- ) @@ -15,7 +14,6 @@ IN: db2.sqlite.lib } case ; : sqlite-open ( path -- db ) - normalize-path "void*" [ sqlite3_open sqlite-check-result ] keep *void* ; @@ -110,5 +108,3 @@ IN: db2.sqlite.lib : sqlite-next ( prepared -- ? ) sqlite3_step sqlite-step-has-more-rows? ; -: >sqlite-result-set ( statement -- result-set ) - sqlite-result-set new-result-set dup advance-row ; diff --git a/extra/db2/sqlite/result-sets/result-sets.factor b/extra/db2/sqlite/result-sets/result-sets.factor index f3d677ed21..3b3226ef39 100644 --- a/extra/db2/sqlite/result-sets/result-sets.factor +++ b/extra/db2/sqlite/result-sets/result-sets.factor @@ -11,7 +11,8 @@ M: sqlite-result-set dispose f >>handle drop ; M: sqlite-statement statement>result-set* - prepare-statement >sqlite-result-set ; + prepare-statement + sqlite-result-set new-result-set dup advance-row ; M: sqlite-result-set advance-row ( result-set -- ) dup handle>> sqlite-next >>has-more? drop ; From f9afd7136931a5e31b89aa0f8dc5922a0d4063b6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 16 Apr 2009 15:19:05 -0500 Subject: [PATCH 25/98] add more db.utils --- extra/db2/utils/utils.factor | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/extra/db2/utils/utils.factor b/extra/db2/utils/utils.factor index 71fa9bc5ae..0557593209 100644 --- a/extra/db2/utils/utils.factor +++ b/extra/db2/utils/utils.factor @@ -1,14 +1,32 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.parser strings ; +USING: arrays kernel math math.parser strings sequences +words ; IN: db2.utils : ?when ( object quot -- object' ) dupd when ; inline : ?1array ( obj -- array ) dup string? [ 1array ] when ; inline : ??1array ( obj -- array/f ) [ ?1array ] ?when ; inline +: ?first ( sequence -- object/f ) 0 ?nth ; +: ?second ( sequence -- object/f ) 1 ?nth ; + +: ?first2 ( sequence -- object1/f object2/f ) + [ ?first ] [ ?second ] bi ; + : assoc-with ( object sequence quot -- obj curry ) swapd [ [ -rot ] dip call ] 2curry ; inline : ?number>string ( n/string -- string ) dup number? [ number>string ] when ; + +ERROR: no-accessor name ; + +: lookup-accessor ( string -- accessor ) + dup ">>" append "accessors" lookup + [ nip ] [ no-accessor ] if* ; + +ERROR: string-expected object ; + +: ensure-string ( object -- string ) + dup string? [ string-expected ] unless ; From c2a35ecf339f79d0290b4ee14e8279da4f6c9310 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 17 Apr 2009 19:07:45 +1000 Subject: [PATCH 26/98] Fix an example in syntax docs --- core/syntax/syntax-docs.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 33a0096ff9..f869cff506 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -526,10 +526,10 @@ HELP: (( { $notes "Useful for meta-programming with " { $link define-declared } "." } { $examples { $code - "SYMBOL: my-dynamic-word" + "<< SYMBOL: my-dynamic-word" "USING: math random words ;" - "3 { [ + ] [ - ] [ * ] [ / ] } random curry" - "(( x -- y )) define-declared" + "my-dynamic-word 3 { [ + ] [ - ] [ * ] [ / ] } random curry" + "(( x -- y )) define-declared >>" } } ; @@ -789,4 +789,4 @@ HELP: execute( { $syntax "execute( stack -- effect )" } { $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ; -{ POSTPONE: call( POSTPONE: execute( } related-words \ No newline at end of file +{ POSTPONE: call( POSTPONE: execute( } related-words From 47820bda51f4edfc212c5593b78ad57bf2f57241 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Apr 2009 03:04:35 -0500 Subject: [PATCH 27/98] Oops --- basis/smtp/smtp.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 605423820b..bfba9ea28a 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -204,7 +204,7 @@ ERROR: invalid-header-string string ; now timestamp>rfc822 "Date" set message-id "Message-Id" set "1.0" "MIME-Version" set - "quoted-printable" "Content-Transfer-Encoding" set + "base64" "Content-Transfer-Encoding" set { [ from>> "From" set ] [ to>> ", " join "To" set ] From 97b19ff0254aa21bff39cd99ec0a006e11e84f95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Apr 2009 03:04:41 -0500 Subject: [PATCH 28/98] Fix typo in ui.text docs --- basis/ui/text/text-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/text/text-docs.factor b/basis/ui/text/text-docs.factor index 4ac2fbbaa8..c2732754f6 100644 --- a/basis/ui/text/text-docs.factor +++ b/basis/ui/text/text-docs.factor @@ -46,7 +46,7 @@ HELP: offset>x HELP: line-metrics { $values { "font" font } { "string" string } { "metrics" line-metrics } } -{ $contract "Outputs a " { $link line-metrics } " object with text measurements." } ; +{ $contract "Outputs a " { $link metrics } " object with text measurements." } ; ARTICLE: "text-rendering" "Rendering text" "The " { $vocab-link "ui.text" } " vocabulary provides a cross-platform interface to the operating system's native font rendering engine. Currently, it uses Core Text on Mac OS X and FreeType on Windows and X11." From 3148429e0c44a4b71bb5985adfb770bb40d530f5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Apr 2009 03:06:05 -0500 Subject: [PATCH 29/98] Fix texture resizing on S3 hardware on Windows. Reported by Kobi Lurie --- basis/opengl/textures/textures.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index 6bed17f7ab..d103e90bee 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -45,7 +45,7 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed : adjust-texture-dim ( dim -- dim' ) non-power-of-2-textures? get [ - [ next-power-of-2 ] map + [ dup 1 = [ next-power-of-2 ] unless ] map ] unless ; : (tex-image) ( image bitmap -- ) From 425be6a414306d6f6b1bb95ce3ae2cd40995c2ac Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sun, 19 Apr 2009 20:35:54 +0200 Subject: [PATCH 30/98] FUEL: modify directly use/in to set up evaluation context --- extra/fuel/eval/eval.factor | 8 ++++---- misc/fuel/fuel-connection.el | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/fuel/eval/eval.factor b/extra/fuel/eval/eval.factor index ae1c5863a8..26d3999380 100644 --- a/extra/fuel/eval/eval.factor +++ b/extra/fuel/eval/eval.factor @@ -63,13 +63,13 @@ t fuel-eval-res-flag set-global [ (fuel-eval) ] each ; : (fuel-eval-usings) ( usings -- ) - [ "USE: " prepend ] map - (fuel-eval-each) fuel-forget-error fuel-forget-output ; + [ [ use+ ] curry [ drop ] recover ] each + fuel-forget-error fuel-forget-output ; : (fuel-eval-in) ( in -- ) - [ dup "IN: " prepend (fuel-eval) in set ] when* ; + [ in set ] when* ; : (fuel-eval-in-context) ( lines in usings -- ) (fuel-begin-eval) - [ (fuel-eval-usings) (fuel-eval-in) "\n" join (fuel-eval) ] with-string-writer + [ (fuel-eval-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer (fuel-end-eval) ; diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el index f180d0f2b4..ef39b7af65 100644 --- a/misc/fuel/fuel-connection.el +++ b/misc/fuel/fuel-connection.el @@ -164,7 +164,7 @@ (fuel-con--send-string/wait buffer fuel-con--init-stanza 'fuel-con--establish-connection-cont - 60000) + 3000000) conn)) (defun fuel-con--establish-connection-cont (ignore) From d039f9a946dfc414213e7dd297f5dc47708cfa95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Apr 2009 17:38:20 -0500 Subject: [PATCH 31/98] help.handbook: fix typos reported by Jon Kleiser --- basis/help/handbook/handbook.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index ebce042e06..1aac99defe 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -13,13 +13,13 @@ ARTICLE: "conventions" "Conventions" { $heading "Documentation conventions" } "Factor documentation consists of two distinct bodies of text. There is a hierarchy of articles, much like this one, and there is word documentation. Help articles reference word documentation, and vice versa, but not every documented word is referenced from some help article." $nl -"Every article has links to parent articles at the top. These can be persued if the article is too specific." +"Every article has links to parent articles at the top. Explore these if the article you are reading is too specific." $nl "Some generic words have " { $strong "Description" } " headings, and others have " { $strong "Contract" } " headings. A distinction is made between words which are not intended to be extended with user-defined methods, and those that are." { $heading "Vocabulary naming conventions" } "A vocabulary name ending in " { $snippet ".private" } " contains words which are either implementation detail, unsafe, or both. For example, the " { $snippet "sequence.private" } " vocabulary contains words which access sequence elements without bounds checking (" { $link "sequences-unsafe" } ")." $nl -"You should should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason." +"You should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason." { $heading "Word naming conventions" } "These conventions are not hard and fast, but are usually a good first step in understanding a word's behavior:" { $table From d3d131d1bda39f6405d806dcfd6278d8e16fb697 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Apr 2009 17:38:48 -0500 Subject: [PATCH 32/98] Strip out error-list related global variables; webkit-demo 14kb smaller --- basis/tools/deploy/shaker/shaker.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 37eec5eae2..ba0daf6056 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -15,6 +15,7 @@ QUALIFIED: definitions QUALIFIED: init QUALIFIED: layouts QUALIFIED: source-files +QUALIFIED: source-files.errors QUALIFIED: vocabs IN: tools.deploy.shaker @@ -264,6 +265,7 @@ IN: tools.deploy.shaker compiled-crossref compiled-generic-crossref compiler-impl + compiler.errors:compiler-errors definition-observers definitions:crossref interactive-vocabs @@ -275,6 +277,7 @@ IN: tools.deploy.shaker lexer-factory print-use-hook root-cache + source-files.errors:error-types vocabs:dictionary vocabs:load-vocab-hook word From 27928f5f8f9b45e40a9d111212e9f2251f32cfce Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Apr 2009 17:39:26 -0500 Subject: [PATCH 33/98] Make couchdb unportable for now --- extra/couchdb/tags.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 extra/couchdb/tags.txt diff --git a/extra/couchdb/tags.txt b/extra/couchdb/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/couchdb/tags.txt @@ -0,0 +1 @@ +unportable From 57d718113e8661c509151336ddb8747eb02d3305 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Apr 2009 18:21:25 -0500 Subject: [PATCH 34/98] tools.test: more robust must-fail --- basis/tools/test/test-tests.factor | 16 +++++++++++++++- basis/tools/test/test.factor | 12 ++++++------ 2 files changed, 21 insertions(+), 7 deletions(-) diff --git a/basis/tools/test/test-tests.factor b/basis/tools/test/test-tests.factor index 473335645f..03f7f006c9 100644 --- a/basis/tools/test/test-tests.factor +++ b/basis/tools/test/test-tests.factor @@ -1,4 +1,18 @@ IN: tools.test.tests -USING: tools.test ; +USING: tools.test tools.test.private namespaces kernel sequences ; \ test-all must-infer + +: fake-unit-test ( quot -- ) + [ + "fake" file set + V{ } clone test-failures set + call + test-failures get + ] with-scope ; inline + +[ 1 ] [ + [ + [ "OOPS" ] must-fail + ] fake-unit-test length +] unit-test \ No newline at end of file diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index b98f58b143..1ff47e3d7f 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -48,17 +48,17 @@ SYMBOL: file f file get f failure ; :: (unit-test) ( output input -- error ? ) - [ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; inline + [ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; : short-effect ( effect -- pair ) [ in>> length ] [ out>> length ] bi 2array ; :: (must-infer-as) ( effect quot -- error ? ) - [ quot infer short-effect effect assert= f f ] [ t ] recover ; inline + [ quot infer short-effect effect assert= f f ] [ t ] recover ; :: (must-infer) ( word/quot -- error ? ) word/quot dup word? [ '[ _ execute ] ] when :> quot - [ quot infer drop f f ] [ t ] recover ; inline + [ quot infer drop f f ] [ t ] recover ; TUPLE: did-not-fail ; CONSTANT: did-not-fail T{ did-not-fail } @@ -66,11 +66,11 @@ CONSTANT: did-not-fail T{ did-not-fail } M: did-not-fail summary drop "Did not fail" ; :: (must-fail-with) ( quot pred -- error ? ) - [ quot call did-not-fail t ] - [ dup pred call [ drop f f ] [ t ] if ] recover ; inline + [ { } quot with-datastack drop did-not-fail t ] + [ dup pred call( error -- ? ) [ drop f f ] [ t ] if ] recover ; :: (must-fail) ( quot -- error ? ) - [ quot call did-not-fail t ] [ drop f f ] recover ; inline + [ { } quot with-datastack drop did-not-fail t ] [ drop f f ] recover ; : experiment-title ( word -- string ) "(" ?head drop ")" ?tail drop { { CHAR: - CHAR: \s } } substitute >title ; From 0719d8365337981d4ee2cc9c5f26be2fe023084d Mon Sep 17 00:00:00 2001 From: Elliott Hird Date: Mon, 20 Apr 2009 01:28:41 +0100 Subject: [PATCH 35/98] Show the signal name next to the number in parentheses on Unices. --- basis/debugger/debugger.factor | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 49ec534e8f..64bac3ecee 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -88,8 +88,27 @@ M: string error. print ; : divide-by-zero-error. ( obj -- ) "Division by zero" print drop ; +CONSTANT: signal-names +{ + "SIGHUP" "SIGINT" "SIGQUIT" "SIGILL" "SIGTRAP" "SIGABRT" + "SIGEMT" "SIGFPE" "SIGKILL" "SIGBUS" "SIGSEGV" "SIGSYS" + "SIGPIPE" "SIGALRM" "SIGTERM" "SIGURG" "SIGSTOP" "SIGTSIP" + "SIGCONT" "SIGCHLD" "SIGTTIN" "SIGTTOU" "SIGIO" "SIGXCPU" + "SIGXFSZ" "SIGVTALRM" "SIGPROF" "SIGWINCH" "SIGINFO" + "SIGUSR1" "SIGUSR2" +} + +: signal-name ( n -- str ) + 1- signal-names nth; + +: signal-name. ( n -- ) + dup signal-names length <= + os unix? and + [ " (" write signal-name write ")" write ] [ drop ] if ; + : signal-error. ( obj -- ) - "Operating system signal " write third . ; + "Operating system signal " write + third [ pprint ] [ signal-name. ] bi nl ; : array-size-error. ( obj -- ) "Invalid array size: " write dup third . From 0f82f4af8709cf85329863f31712c72963db8a5d Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 20 Apr 2009 11:00:38 +1000 Subject: [PATCH 36/98] Merging Diego Martinelli's improvements and simplifications of morse --- extra/morse/authors.txt | 1 + extra/morse/morse-docs.factor | 4 +- extra/morse/morse-tests.factor | 34 +++++- extra/morse/morse.factor | 208 ++++++++++++++++----------------- 4 files changed, 134 insertions(+), 113 deletions(-) diff --git a/extra/morse/authors.txt b/extra/morse/authors.txt index e9c193bac7..409f0443a6 100644 --- a/extra/morse/authors.txt +++ b/extra/morse/authors.txt @@ -1 +1,2 @@ Alex Chapman +Diego Martinelli diff --git a/extra/morse/morse-docs.factor b/extra/morse/morse-docs.factor index e35967d3e9..93350ad02d 100644 --- a/extra/morse/morse-docs.factor +++ b/extra/morse/morse-docs.factor @@ -6,12 +6,12 @@ IN: morse HELP: ch>morse { $values { "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } } -{ $description "If the given character has a morse code translation, then return that translation, otherwise return an empty string." } ; +{ $description "If the given character has a morse code translation, then return that translation, otherwise return a ? character." } ; HELP: morse>ch { $values { "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } } -{ $description "If the given string represents a morse code character, then return that character, otherwise return f" } ; +{ $description "If the given string represents a morse code character, then return that character, otherwise return a space character." } ; HELP: >morse { $values diff --git a/extra/morse/morse-tests.factor b/extra/morse/morse-tests.factor index 144448917f..fd52df1c4d 100644 --- a/extra/morse/morse-tests.factor +++ b/extra/morse/morse-tests.factor @@ -1,13 +1,43 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. USING: arrays morse strings tools.test ; +IN: morse.tests -[ "" ] [ CHAR: \\ ch>morse ] unit-test +[ CHAR: ? ] [ CHAR: \\ ch>morse ] unit-test [ "..." ] [ CHAR: s ch>morse ] unit-test [ CHAR: s ] [ "..." morse>ch ] unit-test -[ f ] [ "..--..--.." morse>ch ] unit-test +[ CHAR: \s ] [ "..--..--.." morse>ch ] unit-test [ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test [ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test [ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test +[ ".- -... -.-." ] [ "abc" >morse ] unit-test + +[ "abc" ] [ ".- -... -.-." morse> ] unit-test + +[ "morse code" ] [ + [MORSE + -- --- .-. ... . / + -.-. --- -.. . + MORSE] >morse morse> ] unit-test + +[ "morse code 123" ] [ + [MORSE + __ ___ ._. ... . / + _._. ___ _.. . / + .____ ..___ ...__ + MORSE] ] unit-test + +[ [MORSE + -- --- .-. ... . / + -.-. --- -.. . + MORSE] ] [ + "morse code" >morse morse> +] unit-test + +[ "factor rocks!" ] [ + [MORSE + ..-. .- -.-. - --- .-. / + .-. --- -.-. -.- ... -.-.-- + MORSE] ] unit-test ! [ ] [ "sos" 0.075 play-as-morse* ] unit-test ! [ ] [ "Factor rocks!" play-as-morse ] unit-test diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index 54abce9395..49e6ae39f5 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -1,130 +1,120 @@ -! Copyright (C) 2007, 2008 Alex Chapman +! Copyright (C) 2007, 2008, 2009 Alex Chapman, 2009 Diego Martinelli ! See http://factorcode.org/license.txt for BSD license. -USING: accessors ascii assocs combinators hashtables kernel lists math -namespaces make openal parser-combinators promises sequences -strings synth synth.buffers unicode.case ; +USING: accessors ascii assocs biassocs combinators hashtables kernel lists math +namespaces make multiline openal parser sequences splitting strings synth synth.buffers ; IN: morse morse-assoc ( -- assoc ) - morse-codes >hashtable ; - -: morse>ch-assoc ( -- assoc ) - morse-codes [ reverse ] map >hashtable ; +CONSTANT: dot-char CHAR: . +CONSTANT: dash-char CHAR: - +CONSTANT: char-gap-char CHAR: \s +CONSTANT: word-gap-char CHAR: / +CONSTANT: unknown-char CHAR: ? PRIVATE> -: ch>morse ( ch -- str ) - ch>lower ch>morse-assoc at* swap "" ? ; +DEFER: morse-code-table + +H{ + { CHAR: a ".-" } + { CHAR: b "-..." } + { CHAR: c "-.-." } + { CHAR: d "-.." } + { CHAR: e "." } + { CHAR: f "..-." } + { CHAR: g "--." } + { CHAR: h "...." } + { CHAR: i ".." } + { CHAR: j ".---" } + { CHAR: k "-.-" } + { CHAR: l ".-.." } + { CHAR: m "--" } + { CHAR: n "-." } + { CHAR: o "---" } + { CHAR: p ".--." } + { CHAR: q "--.-" } + { CHAR: r ".-." } + { CHAR: s "..." } + { CHAR: t "-" } + { CHAR: u "..-" } + { CHAR: v "...-" } + { CHAR: w ".--" } + { CHAR: x "-..-" } + { CHAR: y "-.--" } + { CHAR: z "--.." } + { CHAR: 1 ".----" } + { CHAR: 2 "..---" } + { CHAR: 3 "...--" } + { CHAR: 4 "....-" } + { CHAR: 5 "....." } + { CHAR: 6 "-...." } + { CHAR: 7 "--..." } + { CHAR: 8 "---.." } + { CHAR: 9 "----." } + { CHAR: 0 "-----" } + { CHAR: . ".-.-.-" } + { CHAR: , "--..--" } + { CHAR: ? "..--.." } + { CHAR: ' ".----." } + { CHAR: ! "-.-.--" } + { CHAR: / "-..-." } + { CHAR: ( "-.--." } + { CHAR: ) "-.--.-" } + { CHAR: & ".-..." } + { CHAR: : "---..." } + { CHAR: ; "-.-.-." } + { CHAR: = "-...- " } + { CHAR: + ".-.-." } + { CHAR: - "-....-" } + { CHAR: _ "..--.-" } + { CHAR: " ".-..-." } + { CHAR: $ "...-..-" } + { CHAR: @ ".--.-." } + { CHAR: \s "/" } +} >biassoc \ morse-code-table set-global + +: morse-code-table ( -- biassoc ) + \ morse-code-table get-global ; + +: ch>morse ( ch -- morse ) + ch>lower morse-code-table at [ unknown-char ] unless* ; : morse>ch ( str -- ch ) - morse>ch-assoc at* swap f ? ; - -: >morse ( str -- str ) - [ - [ CHAR: \s , ] [ ch>morse % ] interleave - ] "" make ; - + morse-code-table value-at [ char-gap-char ] unless* ; + morse ( str -- morse ) + [ ch>morse ] { } map-as " " join ; -: dot-char ( -- ch ) CHAR: . ; -: dash-char ( -- ch ) CHAR: - ; -: char-gap-char ( -- ch ) CHAR: \s ; -: word-gap-char ( -- ch ) CHAR: / ; +: sentence>morse ( str -- morse ) + " " split [ word>morse ] map " / " join ; + +: trim-blanks ( str -- newstr ) + [ blank? ] trim ; inline -: =parser ( obj -- parser ) - [ = ] curry satisfy ; +: morse>word ( morse -- str ) + " " split [ morse>ch ] "" map-as ; -LAZY: 'dot' ( -- parser ) - dot-char =parser ; +: morse>sentence ( morse -- sentence ) + "/" split [ trim-blanks morse>word ] map " " join ; -LAZY: 'dash' ( -- parser ) - dash-char =parser ; - -LAZY: 'char-gap' ( -- parser ) - char-gap-char =parser ; - -LAZY: 'word-gap' ( -- parser ) - word-gap-char =parser ; - -LAZY: 'morse-char' ( -- parser ) - 'dot' 'dash' <|> <+> ; - -LAZY: 'morse-word' ( -- parser ) - 'morse-char' 'char-gap' list-of ; - -LAZY: 'morse-words' ( -- parser ) - 'morse-word' 'word-gap' list-of ; +: replace-underscores ( str -- str' ) + [ dup CHAR: _ = [ drop CHAR: - ] when ] map ; PRIVATE> + +: >morse ( str -- newstr ) + trim-blanks sentence>morse ; + +: morse> ( morse -- plain ) + replace-underscores morse>sentence ; -: morse> ( str -- str ) - 'morse-words' parse car parsed>> [ - [ - >string morse>ch - ] map >string - ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ; - +SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> parsed ; + ( -- buffer ) half-sample-freq <8bit-mono-buffer> ; From 616996ab6a77b614538b0ccd09dd179306e09d6c Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 20 Apr 2009 12:20:03 +1000 Subject: [PATCH 37/98] Updating code to use CONSTANT: --- extra/jamshred/game/game.factor | 2 +- extra/jamshred/gl/gl.factor | 15 +++++++-------- extra/jamshred/jamshred.factor | 4 ++-- extra/jamshred/player/player.factor | 4 ++-- extra/jamshred/tunnel/tunnel.factor | 12 +++++++----- extra/synth/buffers/buffers.factor | 10 +++++----- 6 files changed, 24 insertions(+), 23 deletions(-) diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor index 9cb5bc7c3a..14bf18a9c1 100644 --- a/extra/jamshred/game/game.factor +++ b/extra/jamshred/game/game.factor @@ -29,7 +29,7 @@ TUPLE: jamshred sounds tunnel players running quit ; : mouse-moved ( x-radians y-radians jamshred -- ) jamshred-player -rot turn-player ; -: units-per-full-roll ( -- n ) 50 ; +CONSTANT: units-per-full-roll 50 : jamshred-roll ( jamshred n -- ) [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ; diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index bae275e96a..a1d22c48dc 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -6,18 +6,17 @@ math.functions math.vectors opengl opengl.gl opengl.glu opengl.demo-support sequences specialized-arrays.float ; IN: jamshred.gl -: min-vertices ( -- n ) 6 ; inline -: max-vertices ( -- n ) 32 ; inline +CONSTANT: min-vertices 6 +CONSTANT: max-vertices 32 -: n-vertices ( -- n ) 32 ; inline +CONSTANT: n-vertices 32 ! render enough of the tunnel that it looks continuous -: n-segments-ahead ( -- n ) 60 ; inline -: n-segments-behind ( -- n ) 40 ; inline +CONSTANT: n-segments-ahead 60 +CONSTANT: n-segments-behind 40 -: wall-drawing-offset ( -- n ) - #! so that we can't see through the wall, we draw it a bit further away - 0.15 ; +! so that we can't see through the wall, we draw it a bit further away +CONSTANT: wall-drawing-offset 0.15 : wall-drawing-radius ( segment -- r ) radius>> wall-drawing-offset + ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 49624e2947..fd683e3bc4 100644 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -8,8 +8,8 @@ TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ; : ( jamshred -- gadget ) jamshred-gadget new swap >>jamshred ; -: default-width ( -- x ) 800 ; -: default-height ( -- y ) 600 ; +CONSTANT: default-width 800 +CONSTANT: default-height 600 M: jamshred-gadget pref-dim* drop default-width default-height 2array ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index d33b78f29c..5b92b3a434 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -12,8 +12,8 @@ TUPLE: player < oint { speed float } ; ! speeds are in GL units / second -: default-speed ( -- speed ) 1.0 ; -: max-speed ( -- speed ) 30.0 ; +CONSTANT: default-speed 1.0 +CONSTANT: max-speed 30.0 : ( name sounds -- player ) [ float-array{ 0 0 5 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] 2dip diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 4c4b3e6812..d951a37f0c 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -3,7 +3,7 @@ USING: accessors arrays colors combinators kernel locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ; IN: jamshred.tunnel -: n-segments ( -- n ) 5000 ; inline +CONSTANT: n-segments 5000 TUPLE: segment < oint number color radius ; C: segment @@ -14,8 +14,10 @@ C: segment : random-color ( -- color ) { 100 100 100 } [ random 100 / >float ] map first3 1.0 ; -: tunnel-segment-distance ( -- n ) 0.4 ; -: random-rotation-angle ( -- theta ) pi 20 / ; +CONSTANT: tunnel-segment-distance 0.4 +USE: words.constant +DEFER: random-rotation-angle +\ random-rotation-angle pi 20 / define-constant : random-segment ( previous-segment -- segment ) clone dup random-rotation-angle random-turn @@ -27,7 +29,7 @@ C: segment [ dup peek random-segment over push ] dip 1- (random-segments) ] [ drop ] if ; -: default-segment-radius ( -- r ) 1 ; +CONSTANT: default-segment-radius 1 : initial-segment ( -- segment ) float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } @@ -115,7 +117,7 @@ C: segment : wall-normal ( seg oint -- n ) location>> vector-to-centre normalize ; -: distant ( -- n ) 1000 ; +CONSTANT: distant 1000 : max-real ( a b -- c ) #! sometimes collision-coefficient yields complex roots, so we ignore these (hack) diff --git a/extra/synth/buffers/buffers.factor b/extra/synth/buffers/buffers.factor index 671ebead63..4c0ef64607 100644 --- a/extra/synth/buffers/buffers.factor +++ b/extra/synth/buffers/buffers.factor @@ -57,11 +57,11 @@ M: 8bit-stereo-buffer buffer-data M: 16bit-stereo-buffer buffer-data interleaved-stereo-data 16bit-buffer-data ; -: telephone-sample-freq ( -- n ) 8000 ; -: half-sample-freq ( -- n ) 22050 ; -: cd-sample-freq ( -- n ) 44100 ; -: digital-sample-freq ( -- n ) 48000 ; -: professional-sample-freq ( -- n ) 88200 ; +CONSTANT: telephone-sample-freq 8000 +CONSTANT: half-sample-freq 22050 +CONSTANT: cd-sample-freq 44100 +CONSTANT: digital-sample-freq 48000 +CONSTANT: professional-sample-freq 88200 : send-buffer ( buffer -- buffer ) { From 0e6f76c13d8ded676ea792020f74e1fae00eae84 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 20 Apr 2009 14:15:38 +1000 Subject: [PATCH 38/98] Using literals vocab for defining computed constants --- extra/jamshred/tunnel/tunnel.factor | 6 +- extra/morse/morse.factor | 124 ++++++++++++++-------------- 2 files changed, 62 insertions(+), 68 deletions(-) diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index d951a37f0c..6171c3053b 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays colors combinators kernel locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ; +USING: accessors arrays colors combinators kernel literals locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ; IN: jamshred.tunnel CONSTANT: n-segments 5000 @@ -15,9 +15,7 @@ C: segment { 100 100 100 } [ random 100 / >float ] map first3 1.0 ; CONSTANT: tunnel-segment-distance 0.4 -USE: words.constant -DEFER: random-rotation-angle -\ random-rotation-angle pi 20 / define-constant +CONSTANT: random-rotation-angle $[ pi 20 / ] : random-segment ( previous-segment -- segment ) clone dup random-rotation-angle random-turn diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index 49e6ae39f5..ef4b9d4b88 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2007, 2008, 2009 Alex Chapman, 2009 Diego Martinelli ! See http://factorcode.org/license.txt for BSD license. -USING: accessors ascii assocs biassocs combinators hashtables kernel lists math -namespaces make multiline openal parser sequences splitting strings synth synth.buffers ; +USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ; IN: morse -DEFER: morse-code-table - -H{ - { CHAR: a ".-" } - { CHAR: b "-..." } - { CHAR: c "-.-." } - { CHAR: d "-.." } - { CHAR: e "." } - { CHAR: f "..-." } - { CHAR: g "--." } - { CHAR: h "...." } - { CHAR: i ".." } - { CHAR: j ".---" } - { CHAR: k "-.-" } - { CHAR: l ".-.." } - { CHAR: m "--" } - { CHAR: n "-." } - { CHAR: o "---" } - { CHAR: p ".--." } - { CHAR: q "--.-" } - { CHAR: r ".-." } - { CHAR: s "..." } - { CHAR: t "-" } - { CHAR: u "..-" } - { CHAR: v "...-" } - { CHAR: w ".--" } - { CHAR: x "-..-" } - { CHAR: y "-.--" } - { CHAR: z "--.." } - { CHAR: 1 ".----" } - { CHAR: 2 "..---" } - { CHAR: 3 "...--" } - { CHAR: 4 "....-" } - { CHAR: 5 "....." } - { CHAR: 6 "-...." } - { CHAR: 7 "--..." } - { CHAR: 8 "---.." } - { CHAR: 9 "----." } - { CHAR: 0 "-----" } - { CHAR: . ".-.-.-" } - { CHAR: , "--..--" } - { CHAR: ? "..--.." } - { CHAR: ' ".----." } - { CHAR: ! "-.-.--" } - { CHAR: / "-..-." } - { CHAR: ( "-.--." } - { CHAR: ) "-.--.-" } - { CHAR: & ".-..." } - { CHAR: : "---..." } - { CHAR: ; "-.-.-." } - { CHAR: = "-...- " } - { CHAR: + ".-.-." } - { CHAR: - "-....-" } - { CHAR: _ "..--.-" } - { CHAR: " ".-..-." } - { CHAR: $ "...-..-" } - { CHAR: @ ".--.-." } - { CHAR: \s "/" } -} >biassoc \ morse-code-table set-global - -: morse-code-table ( -- biassoc ) - \ morse-code-table get-global ; +CONSTANT: morse-code-table $[ + H{ + { CHAR: a ".-" } + { CHAR: b "-..." } + { CHAR: c "-.-." } + { CHAR: d "-.." } + { CHAR: e "." } + { CHAR: f "..-." } + { CHAR: g "--." } + { CHAR: h "...." } + { CHAR: i ".." } + { CHAR: j ".---" } + { CHAR: k "-.-" } + { CHAR: l ".-.." } + { CHAR: m "--" } + { CHAR: n "-." } + { CHAR: o "---" } + { CHAR: p ".--." } + { CHAR: q "--.-" } + { CHAR: r ".-." } + { CHAR: s "..." } + { CHAR: t "-" } + { CHAR: u "..-" } + { CHAR: v "...-" } + { CHAR: w ".--" } + { CHAR: x "-..-" } + { CHAR: y "-.--" } + { CHAR: z "--.." } + { CHAR: 1 ".----" } + { CHAR: 2 "..---" } + { CHAR: 3 "...--" } + { CHAR: 4 "....-" } + { CHAR: 5 "....." } + { CHAR: 6 "-...." } + { CHAR: 7 "--..." } + { CHAR: 8 "---.." } + { CHAR: 9 "----." } + { CHAR: 0 "-----" } + { CHAR: . ".-.-.-" } + { CHAR: , "--..--" } + { CHAR: ? "..--.." } + { CHAR: ' ".----." } + { CHAR: ! "-.-.--" } + { CHAR: / "-..-." } + { CHAR: ( "-.--." } + { CHAR: ) "-.--.-" } + { CHAR: & ".-..." } + { CHAR: : "---..." } + { CHAR: ; "-.-.-." } + { CHAR: = "-...- " } + { CHAR: + ".-.-." } + { CHAR: - "-....-" } + { CHAR: _ "..--.-" } + { CHAR: " ".-..-." } + { CHAR: $ "...-..-" } + { CHAR: @ ".--.-." } + { CHAR: \s "/" } + } >biassoc +] : ch>morse ( ch -- morse ) ch>lower morse-code-table at [ unknown-char ] unless* ; From bcd05337943f0b694ed0b54c1a94d3ca55e170bc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 01:42:54 -0500 Subject: [PATCH 39/98] Improve example in syntax vocab --- core/syntax/syntax-docs.factor | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index f869cff506..73335e09cf 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -525,11 +525,19 @@ HELP: (( { $description "Literal stack effect syntax." } { $notes "Useful for meta-programming with " { $link define-declared } "." } { $examples - { $code - "<< SYMBOL: my-dynamic-word" - "USING: math random words ;" - "my-dynamic-word 3 { [ + ] [ - ] [ * ] [ / ] } random curry" - "(( x -- y )) define-declared >>" + { $example + "USING: compiler.units kernel math prettyprint random words ;" + "IN: scratchpad" + "" + "SYMBOL: my-dynamic-word" + "" + "[" + " my-dynamic-word 2 { [ + ] [ * ] } random curry" + " (( x -- y )) define-declared" + "] with-compilation-unit" + "" + "2 my-dynamic-word ." + "4" } } ; From 86e5ddf449aa283ca3894b46b43cdd23df13bec7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 01:47:10 -0500 Subject: [PATCH 40/98] Improve Unix signal and Windows structured exception reporting --- basis/debugger/debugger.factor | 29 +++++++-------------------- basis/debugger/unix/authors.txt | 1 + basis/debugger/unix/unix.factor | 23 +++++++++++++++++++++ basis/debugger/windows/authors.txt | 1 + basis/debugger/windows/windows.factor | 6 ++++++ 5 files changed, 38 insertions(+), 22 deletions(-) create mode 100644 basis/debugger/unix/authors.txt create mode 100644 basis/debugger/unix/unix.factor create mode 100644 basis/debugger/windows/authors.txt create mode 100644 basis/debugger/windows/windows.factor diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 64bac3ecee..9abd5a9033 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -88,27 +88,7 @@ M: string error. print ; : divide-by-zero-error. ( obj -- ) "Division by zero" print drop ; -CONSTANT: signal-names -{ - "SIGHUP" "SIGINT" "SIGQUIT" "SIGILL" "SIGTRAP" "SIGABRT" - "SIGEMT" "SIGFPE" "SIGKILL" "SIGBUS" "SIGSEGV" "SIGSYS" - "SIGPIPE" "SIGALRM" "SIGTERM" "SIGURG" "SIGSTOP" "SIGTSIP" - "SIGCONT" "SIGCHLD" "SIGTTIN" "SIGTTOU" "SIGIO" "SIGXCPU" - "SIGXFSZ" "SIGVTALRM" "SIGPROF" "SIGWINCH" "SIGINFO" - "SIGUSR1" "SIGUSR2" -} - -: signal-name ( n -- str ) - 1- signal-names nth; - -: signal-name. ( n -- ) - dup signal-names length <= - os unix? and - [ " (" write signal-name write ")" write ] [ drop ] if ; - -: signal-error. ( obj -- ) - "Operating system signal " write - third [ pprint ] [ signal-name. ] bi nl ; +HOOK: signal-error. os ( obj -- ) : array-size-error. ( obj -- ) "Invalid array size: " write dup third . @@ -325,4 +305,9 @@ M: check-mixin-class summary drop "Not a mixin class" ; M: not-found-in-roots summary drop "Cannot resolve vocab: path" ; -M: wrong-values summary drop "Quotation called with wrong stack effect" ; \ No newline at end of file +M: wrong-values summary drop "Quotation called with wrong stack effect" ; + +{ + { [ os windows? ] [ "debugger.windows" require ] } + { [ os unix? ] [ "debugger.unix" require ] } +} cond \ No newline at end of file diff --git a/basis/debugger/unix/authors.txt b/basis/debugger/unix/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/debugger/unix/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/debugger/unix/unix.factor b/basis/debugger/unix/unix.factor new file mode 100644 index 0000000000..212908b2fd --- /dev/null +++ b/basis/debugger/unix/unix.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: debugger io kernel math prettyprint sequences system ; +IN: debugger.unix + +CONSTANT: signal-names +{ + "SIGHUP" "SIGINT" "SIGQUIT" "SIGILL" "SIGTRAP" "SIGABRT" + "SIGEMT" "SIGFPE" "SIGKILL" "SIGBUS" "SIGSEGV" "SIGSYS" + "SIGPIPE" "SIGALRM" "SIGTERM" "SIGURG" "SIGSTOP" "SIGTSIP" + "SIGCONT" "SIGCHLD" "SIGTTIN" "SIGTTOU" "SIGIO" "SIGXCPU" + "SIGXFSZ" "SIGVTALRM" "SIGPROF" "SIGWINCH" "SIGINFO" + "SIGUSR1" "SIGUSR2" +} + +: signal-name ( n -- str/f ) 1- signal-names ?nth ; + +: signal-name. ( n -- ) + signal-name [ " (" ")" surround write ] when* ; + +M: unix signal-error. ( obj -- ) + "Unix signal #" write + third [ pprint ] [ signal-name. ] bi nl ; diff --git a/basis/debugger/windows/authors.txt b/basis/debugger/windows/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/debugger/windows/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/debugger/windows/windows.factor b/basis/debugger/windows/windows.factor new file mode 100644 index 0000000000..1f4b8fb0ac --- /dev/null +++ b/basis/debugger/windows/windows.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: debugger io prettyprint sequences system ; +IN: debugger.windows + +M: windows signal-error. "Windows exception #" write third .h ; \ No newline at end of file From 5ac1358aea56fd86bc93206cc940795f0849f4fc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 01:55:27 -0500 Subject: [PATCH 41/98] Report actual SEH code on Windows instead of 'signal 11' --- vm/bignum.c | 6 +++--- vm/errors.c | 9 ++------- vm/errors.h | 3 +-- vm/os-windows-nt.c | 8 +------- 4 files changed, 7 insertions(+), 19 deletions(-) mode change 100644 => 100755 vm/bignum.c diff --git a/vm/bignum.c b/vm/bignum.c old mode 100644 new mode 100755 index 497a4bbf62..c799691f36 --- a/vm/bignum.c +++ b/vm/bignum.c @@ -170,7 +170,7 @@ bignum_divide(bignum_type numerator, bignum_type denominator, { if (BIGNUM_ZERO_P (denominator)) { - divide_by_zero_error(NULL); + divide_by_zero_error(); return; } if (BIGNUM_ZERO_P (numerator)) @@ -242,7 +242,7 @@ bignum_quotient(bignum_type numerator, bignum_type denominator) { if (BIGNUM_ZERO_P (denominator)) { - divide_by_zero_error(NULL); + divide_by_zero_error(); return (BIGNUM_OUT_OF_BAND); } if (BIGNUM_ZERO_P (numerator)) @@ -295,7 +295,7 @@ bignum_remainder(bignum_type numerator, bignum_type denominator) { if (BIGNUM_ZERO_P (denominator)) { - divide_by_zero_error(NULL); + divide_by_zero_error(); return (BIGNUM_OUT_OF_BAND); } if (BIGNUM_ZERO_P (numerator)) diff --git a/vm/errors.c b/vm/errors.c index 9b7b7843d2..8e7b4818bf 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -124,9 +124,9 @@ void signal_error(int signal, F_STACK_FRAME *native_stack) general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack); } -void divide_by_zero_error(F_STACK_FRAME *native_stack) +void divide_by_zero_error(void) { - general_error(ERROR_DIVIDE_BY_ZERO,F,F,native_stack); + general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL); } void memory_signal_handler_impl(void) @@ -134,11 +134,6 @@ void memory_signal_handler_impl(void) memory_protection_error(signal_fault_addr,signal_callstack_top); } -void divide_by_zero_signal_handler_impl(void) -{ - divide_by_zero_error(signal_callstack_top); -} - void misc_signal_handler_impl(void) { signal_error(signal_number,signal_callstack_top); diff --git a/vm/errors.h b/vm/errors.h index da3ee8bbe0..56aaf60d54 100755 --- a/vm/errors.h +++ b/vm/errors.h @@ -26,7 +26,7 @@ void primitive_die(void); void throw_error(CELL error, F_STACK_FRAME *native_stack); void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack); -void divide_by_zero_error(F_STACK_FRAME *native_stack); +void divide_by_zero_error(void); void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack); void signal_error(int signal, F_STACK_FRAME *native_stack); void type_error(CELL type, CELL tagged); @@ -53,7 +53,6 @@ CELL signal_fault_addr; void *signal_callstack_top; void memory_signal_handler_impl(void); -void divide_by_zero_signal_handler_impl(void); void misc_signal_handler_impl(void); void primitive_unimplemented(void); diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index bcddd0b140..501463378a 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -23,12 +23,6 @@ long exception_handler(PEXCEPTION_POINTERS pe) signal_fault_addr = e->ExceptionInformation[1]; 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; - } /* If the Widcomm bluetooth stack is installed, the BTTray.exe process injects code into running programs. For some reason this results in random SEH exceptions with this (undocumented) exception code being @@ -37,7 +31,7 @@ long exception_handler(PEXCEPTION_POINTERS pe) this exception means. */ else if(e->ExceptionCode != 0x40010006) { - signal_number = 11; + signal_number = e->ExceptionCode; c->EIP = (CELL)misc_signal_handler_impl; } From ec72f33fcbe0d8dee60d83b5d5195653511dfdec Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 02:23:52 -0500 Subject: [PATCH 42/98] Documentation updates --- basis/help/handbook/handbook.factor | 1 + basis/ui/tools/profiler/profiler-docs.factor | 10 +++++++--- basis/ui/tools/tools-docs.factor | 11 ----------- core/combinators/combinators-docs.factor | 6 ------ core/parser/parser-docs.factor | 3 +-- core/quotations/quotations-docs.factor | 6 ++++++ 6 files changed, 15 insertions(+), 22 deletions(-) diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 1aac99defe..a97a46badc 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -249,6 +249,7 @@ ARTICLE: "handbook-language-reference" "The language" { $heading "Abstractions" } { $subsection "objects" } { $subsection "destructors" } +{ $subsection "parsing-words" } { $subsection "macros" } { $subsection "fry" } { $heading "Program organization" } diff --git a/basis/ui/tools/profiler/profiler-docs.factor b/basis/ui/tools/profiler/profiler-docs.factor index e2a0ef5f4e..fad2b3614f 100644 --- a/basis/ui/tools/profiler/profiler-docs.factor +++ b/basis/ui/tools/profiler/profiler-docs.factor @@ -1,10 +1,14 @@ IN: ui.tools.profiler -USING: help.markup help.syntax ui.operations help.tips ; +USING: help.markup help.syntax ui.operations ui.commands help.tips ; -ARTICLE: "ui.tools.profiler" "UI profiler tool" +ARTICLE: "ui.tools.profiler" "UI profiler tool" "The " { $vocab-link "ui.tools.profiler" } " vocabulary implements a graphical tool for viewing profiling results (see " { $link "profiling" } ")." $nl -"To use the profiler, enter a piece of code in the listener's input area and press " { $operation com-profile } "." ; +"To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "." +$nl +"Clicking on a vocabulary in the vocabulary list narrows down the word list to only include words from that vocabulary. The sorting options control the order of elements in the vocabulary and word lists. The search fields narrow down the list to only include words or vocabularies whose names contain a substring." +$nl +"Consult " { $link "profiling" } " for details about the profiler itself." ; TIP: "Press " { $operation com-profile } " to run the code in the input field with profiling enabled (" { $link "ui.tools.profiler" } ")." ; diff --git a/basis/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor index 92aa1be947..7be008f296 100644 --- a/basis/ui/tools/tools-docs.factor +++ b/basis/ui/tools/tools-docs.factor @@ -31,17 +31,6 @@ $nl $nl "For more about presentation gadgets, see " { $link "ui.gadgets.presentations" } "." ; -ARTICLE: "ui-profiler" "UI profiler" -"The graphical profiler is based on the terminal profiler (see " { $link "profiling" } ") and adds more convenient browsing of profiler results." -$nl -"To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "." -$nl -"Clicking on a vocabulary in the vocabulary list narrows down the word list to only include words from that vocabulary. The sorting options control the order of elements in the vocabulary and word lists. The search fields narrow down the list to only include words or vocabularies whose names contain a substring." -$nl -"Consult " { $link "profiling" } " for details about the profiler itself." -{ $command-map profiler-gadget "toolbar" } -"The profiler is an instance of " { $link profiler-gadget } "." ; - ARTICLE: "ui-cocoa" "Functionality specific to Mac OS X" "On Mac OS X, the Factor UI offers additional features which integrate with this operating system." $nl diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 9c96fe34c9..dd55d5fabe 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -303,13 +303,7 @@ ARTICLE: "combinators" "Combinators" { $subsection "combinators.short-circuit" } { $subsection "combinators.smart" } "More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "." -$nl -"The " { $vocab-link "combinators" } " provides some less frequently-used features." -$nl -"A combinator which can help with implementing methods on " { $link hashcode* } ":" -{ $subsection recursive-hashcode } { $subsection "combinators-quot" } -"Advanced topics:" { $see-also "quotations" } ; ABOUT: "combinators" diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index be4b345f4f..ea82f7276f 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -94,11 +94,10 @@ $nl "This section concerns itself with usage and extension of the parser. Standard syntax is described in " { $link "syntax" } "." { $subsection "parser-files" } "The parser can be extended." -{ $subsection "parsing-words" } { $subsection "parser-lexer" } "The parser can be invoked reflectively;" { $subsection parse-stream } -{ $see-also "definitions" "definition-checking" } ; +{ $see-also "parsing-words" "definitions" "definition-checking" } ; ABOUT: "parser" diff --git a/core/quotations/quotations-docs.factor b/core/quotations/quotations-docs.factor index 603d6f2847..364f186d52 100644 --- a/core/quotations/quotations-docs.factor +++ b/core/quotations/quotations-docs.factor @@ -25,6 +25,12 @@ ARTICLE: "wrappers" "Wrappers" { $subsection wrapper } { $subsection literalize } "Wrapper literal syntax is documented in " { $link "syntax-words" } "." +{ $example + "IN: scratchpad" + "DEFER: my-word" + "\\ my-word name>> ." + "\"my-word\"" +} { $see-also "combinators" } ; ABOUT: "quotations" From 0f26d02d41edd2fe4d96d00557d6c1cc68aece6a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 03:26:56 -0500 Subject: [PATCH 43/98] Passing the wrong type of sequence to M\ encoder write now throws an error --- basis/io/files/unique/unique-tests.factor | 2 +- core/io/encodings/encodings.factor | 4 +++- core/io/files/files-tests.factor | 14 +++++++++++++- 3 files changed, 17 insertions(+), 3 deletions(-) diff --git a/basis/io/files/unique/unique-tests.factor b/basis/io/files/unique/unique-tests.factor index fd8cf2c69f..53a77907cf 100644 --- a/basis/io/files/unique/unique-tests.factor +++ b/basis/io/files/unique/unique-tests.factor @@ -5,7 +5,7 @@ IN: io.files.unique.tests [ 123 ] [ "core" ".test" [ - [ [ 123 CHAR: a ] dip ascii set-file-contents ] + [ [ 123 CHAR: a ] dip ascii set-file-contents ] [ file-info size>> ] bi ] cleanup-unique-file ] unit-test diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 696de9af69..174816dd34 100644 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -130,7 +130,9 @@ M: encoder stream-element-type M: encoder stream-write1 >encoder< encode-char ; -: encoder-write ( string stream encoding -- ) +GENERIC# encoder-write 2 ( string stream encoding -- ) + +M: string encoder-write [ encode-char ] 2curry each ; M: encoder stream-write diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index ce15a69773..a2d637dcb7 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,7 +1,7 @@ USING: arrays debugger.threads destructors io io.directories io.encodings.8-bit io.encodings.ascii io.encodings.binary io.files io.files.private io.files.temp io.files.unique kernel -make math sequences system threads tools.test ; +make math sequences system threads tools.test generic.standard ; IN: io.files.tests \ exists? must-infer @@ -144,3 +144,15 @@ USE: debugger.threads -10 seek-absolute seek-input ] with-file-reader ] must-fail + +[ + "non-string-error" unique-file ascii [ + { } write + ] with-file-writer +] [ no-method? ] must-fail-with + +[ + "non-byte-array-error" unique-file binary [ + "" write + ] with-file-writer +] [ no-method? ] must-fail-with \ No newline at end of file From ec49307c88cb0db7b4fd0dc4b1ca0694a0e0c654 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 03:27:18 -0500 Subject: [PATCH 44/98] Never inline default methods, and fix inlining of methods with hints --- .../tree/propagation/inlining/inlining.factor | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 0815351057..7ae44a5293 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -3,7 +3,7 @@ USING: accessors kernel arrays sequences math math.order math.partial-dispatch generic generic.standard generic.math classes.algebra classes.union sets quotations assocs combinators -words namespaces continuations classes fry combinators.smart +words namespaces continuations classes fry combinators.smart hints compiler.tree compiler.tree.builder compiler.tree.recursive @@ -136,12 +136,10 @@ DEFER: (flat-length) [ [ classes-known? 2 0 ? ] [ - { - [ body-length-bias ] - [ "default" word-prop -4 0 ? ] - [ "specializer" word-prop 1 0 ? ] - [ method-body? 1 0 ? ] - } cleave + [ body-length-bias ] + [ "specializer" word-prop 1 0 ? ] + [ method-body? 1 0 ? ] + tri node-count-bias loop-nesting get 0 or 2 * ] bi* @@ -172,7 +170,7 @@ SYMBOL: history ] if ; : inline-word ( #call word -- ? ) - dup def>> inline-word-def ; + dup specialized-def inline-word-def ; : inline-method-body ( #call word -- ? ) 2dup should-inline? [ inline-word ] [ 2drop f ] if ; @@ -181,7 +179,9 @@ SYMBOL: history { curry compose } memq? ; : never-inline-word? ( word -- ? ) - [ deferred? ] [ { call execute } memq? ] bi or ; + [ deferred? ] + [ "default" word-prop ] + [ { call execute } memq? ] tri or or ; : custom-inlining? ( word -- ? ) "custom-inlining" word-prop ; From 7aeb13e58a150a2dd8f4e6065677e9b384b1babb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 03:27:30 -0500 Subject: [PATCH 45/98] io.buffers and io.ports performance tweaks --- basis/io/buffers/buffers.factor | 2 +- basis/io/ports/ports.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor index 4df081b17d..49b5357d98 100644 --- a/basis/io/buffers/buffers.factor +++ b/basis/io/buffers/buffers.factor @@ -22,7 +22,7 @@ M: buffer dispose* ptr>> free ; swap >>fill 0 >>pos drop ; : buffer-capacity ( buffer -- n ) - [ size>> ] [ fill>> ] bi - ; inline + [ size>> ] [ fill>> ] bi - >fixnum ; inline : buffer-empty? ( buffer -- ? ) fill>> zero? ; inline diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 569366d4b8..b2d71fd535 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -189,4 +189,4 @@ HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii } HINTS: decoder-readln { input-port utf8 } { input-port ascii } ; -HINTS: encoder-write { string output-port utf8 } { string output-port ascii } ; +HINTS: encoder-write { object output-port utf8 } { object output-port ascii } ; From 3b40334ccda0cd45398e4f8fd6ffca85c8c0e127 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 03:27:52 -0500 Subject: [PATCH 46/98] xml: fix compile warnings in tests --- basis/xml/tests/state-parser-tests.factor | 2 +- basis/xml/tests/xmltest.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/xml/tests/state-parser-tests.factor b/basis/xml/tests/state-parser-tests.factor index 7616efaf1d..5e214dc4a3 100644 --- a/basis/xml/tests/state-parser-tests.factor +++ b/basis/xml/tests/state-parser-tests.factor @@ -2,7 +2,7 @@ USING: tools.test xml.tokenize xml.state io.streams.string kernel io strings asc IN: xml.test.state : string-parse ( str quot -- ) - [ ] dip with-state ; + [ ] dip with-state ; inline : take-rest ( -- string ) [ f ] take-until ; diff --git a/basis/xml/tests/xmltest.factor b/basis/xml/tests/xmltest.factor index c41b05eb85..55b5147abb 100644 --- a/basis/xml/tests/xmltest.factor +++ b/basis/xml/tests/xmltest.factor @@ -43,7 +43,7 @@ MACRO: drop-input ( quot -- newquot ) xml-tests [ unit-test ] assoc-each ; : works? ( result quot -- ? ) - [ first ] [ call ] bi* = ; + [ first ] [ call( -- result ) ] bi* = ; : partition-xml-tests ( -- successes failures ) xml-tests [ first2 works? ] partition ; From a4d48a1cd466ec356b42e55be51bbd1dbed8ec19 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 03:28:03 -0500 Subject: [PATCH 47/98] xml.writer: don't write arrays to output-stream --- basis/xml/writer/writer-tests.factor | 12 ++++++++++-- basis/xml/writer/writer.factor | 2 +- 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor index f19e845ab9..2d31738c4c 100644 --- a/basis/xml/writer/writer-tests.factor +++ b/basis/xml/writer/writer-tests.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: xml.data xml.writer tools.test fry xml kernel multiline +USING: xml.data xml.writer tools.test fry xml xml.syntax kernel multiline xml.writer.private io.streams.string xml.traversal sequences -io.encodings.utf8 io.files accessors io.directories ; +io.encodings.utf8 io.files accessors io.directories math math.parser ; IN: xml.writer.tests \ write-xml must-infer @@ -66,3 +66,11 @@ CONSTANT: test-file "resource:basis/xml/writer/test.xml" [ ] [ "" string>xml test-file utf8 [ write-xml ] with-file-writer ] unit-test [ "x" ] [ test-file file>xml body>> name>> main>> ] unit-test [ ] [ test-file delete-file ] unit-test + +[ ] [ + { 1 2 3 4 } [ + [ number>string ] [ sq number>string ] bi + [XML <-><-> XML] + ] map [XML

Timings

<->
XML] + pprint-xml +] unit-test \ No newline at end of file diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor index 4f5bad1aa5..ab957ebc75 100755 --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -19,7 +19,7 @@ SYMBOL: indentation : indent-string ( -- string ) xml-pprint? get - [ indentation get indenter get concat ] + [ indentation get indenter get "" join ] [ "" ] if ; : ?indent ( -- ) From dff8f80ea657fc51cdcd8454eba0c774391e4a39 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 03:29:16 -0500 Subject: [PATCH 48/98] mason.report: fix timings-table, and add unit tests --- .../report/fake-data/benchmark-error-messages | 1 + .../report/fake-data/benchmark-error-vocabs | 1 + extra/mason/report/fake-data/benchmark-time | 1 + extra/mason/report/fake-data/benchmarks | 1 + extra/mason/report/fake-data/boot-log | 2 ++ extra/mason/report/fake-data/boot-time | 1 + extra/mason/report/fake-data/compile-log | 2 ++ .../report/fake-data/compiler-error-messages | 1 + extra/mason/report/fake-data/compiler-errors | 1 + extra/mason/report/fake-data/git-id | 1 + extra/mason/report/fake-data/help-lint-errors | 1 + extra/mason/report/fake-data/help-lint-time | 1 + extra/mason/report/fake-data/help-lint-vocabs | 1 + extra/mason/report/fake-data/html-help-time | 1 + .../report/fake-data/load-everything-errors | 1 + .../report/fake-data/load-everything-vocabs | 1 + extra/mason/report/fake-data/load-time | 1 + extra/mason/report/fake-data/test-all-errors | 1 + extra/mason/report/fake-data/test-all-vocabs | 1 + extra/mason/report/fake-data/test-log | 2 ++ extra/mason/report/fake-data/test-time | 1 + extra/mason/report/report-tests.factor | 28 +++++++++++++++++-- extra/mason/report/report.factor | 18 ++++++------ 23 files changed, 59 insertions(+), 11 deletions(-) create mode 100644 extra/mason/report/fake-data/benchmark-error-messages create mode 100644 extra/mason/report/fake-data/benchmark-error-vocabs create mode 100644 extra/mason/report/fake-data/benchmark-time create mode 100644 extra/mason/report/fake-data/benchmarks create mode 100644 extra/mason/report/fake-data/boot-log create mode 100644 extra/mason/report/fake-data/boot-time create mode 100644 extra/mason/report/fake-data/compile-log create mode 100644 extra/mason/report/fake-data/compiler-error-messages create mode 100644 extra/mason/report/fake-data/compiler-errors create mode 100644 extra/mason/report/fake-data/git-id create mode 100644 extra/mason/report/fake-data/help-lint-errors create mode 100644 extra/mason/report/fake-data/help-lint-time create mode 100644 extra/mason/report/fake-data/help-lint-vocabs create mode 100644 extra/mason/report/fake-data/html-help-time create mode 100644 extra/mason/report/fake-data/load-everything-errors create mode 100644 extra/mason/report/fake-data/load-everything-vocabs create mode 100644 extra/mason/report/fake-data/load-time create mode 100644 extra/mason/report/fake-data/test-all-errors create mode 100644 extra/mason/report/fake-data/test-all-vocabs create mode 100644 extra/mason/report/fake-data/test-log create mode 100644 extra/mason/report/fake-data/test-time diff --git a/extra/mason/report/fake-data/benchmark-error-messages b/extra/mason/report/fake-data/benchmark-error-messages new file mode 100644 index 0000000000..f738144e3c --- /dev/null +++ b/extra/mason/report/fake-data/benchmark-error-messages @@ -0,0 +1 @@ +Benchmarks diff --git a/extra/mason/report/fake-data/benchmark-error-vocabs b/extra/mason/report/fake-data/benchmark-error-vocabs new file mode 100644 index 0000000000..b5a85b9c41 --- /dev/null +++ b/extra/mason/report/fake-data/benchmark-error-vocabs @@ -0,0 +1 @@ +{ "benchmarks" } diff --git a/extra/mason/report/fake-data/benchmark-time b/extra/mason/report/fake-data/benchmark-time new file mode 100644 index 0000000000..81c545efeb --- /dev/null +++ b/extra/mason/report/fake-data/benchmark-time @@ -0,0 +1 @@ +1234 diff --git a/extra/mason/report/fake-data/benchmarks b/extra/mason/report/fake-data/benchmarks new file mode 100644 index 0000000000..ed8ec42879 --- /dev/null +++ b/extra/mason/report/fake-data/benchmarks @@ -0,0 +1 @@ +H{ { "a" 1 } { "b" 2 } } diff --git a/extra/mason/report/fake-data/boot-log b/extra/mason/report/fake-data/boot-log new file mode 100644 index 0000000000..d9e4d79562 --- /dev/null +++ b/extra/mason/report/fake-data/boot-log @@ -0,0 +1,2 @@ +Boot +Log diff --git a/extra/mason/report/fake-data/boot-time b/extra/mason/report/fake-data/boot-time new file mode 100644 index 0000000000..81c545efeb --- /dev/null +++ b/extra/mason/report/fake-data/boot-time @@ -0,0 +1 @@ +1234 diff --git a/extra/mason/report/fake-data/compile-log b/extra/mason/report/fake-data/compile-log new file mode 100644 index 0000000000..5007c38d13 --- /dev/null +++ b/extra/mason/report/fake-data/compile-log @@ -0,0 +1,2 @@ +Compile +Log diff --git a/extra/mason/report/fake-data/compiler-error-messages b/extra/mason/report/fake-data/compiler-error-messages new file mode 100644 index 0000000000..1a58d6dcf0 --- /dev/null +++ b/extra/mason/report/fake-data/compiler-error-messages @@ -0,0 +1 @@ +Compiler errors diff --git a/extra/mason/report/fake-data/compiler-errors b/extra/mason/report/fake-data/compiler-errors new file mode 100644 index 0000000000..4e5eee20e2 --- /dev/null +++ b/extra/mason/report/fake-data/compiler-errors @@ -0,0 +1 @@ +{ "compiler-errors" } diff --git a/extra/mason/report/fake-data/git-id b/extra/mason/report/fake-data/git-id new file mode 100644 index 0000000000..d4d308b176 --- /dev/null +++ b/extra/mason/report/fake-data/git-id @@ -0,0 +1 @@ +"deadbeef" diff --git a/extra/mason/report/fake-data/help-lint-errors b/extra/mason/report/fake-data/help-lint-errors new file mode 100644 index 0000000000..da540b4802 --- /dev/null +++ b/extra/mason/report/fake-data/help-lint-errors @@ -0,0 +1 @@ +Help lint diff --git a/extra/mason/report/fake-data/help-lint-time b/extra/mason/report/fake-data/help-lint-time new file mode 100644 index 0000000000..81c545efeb --- /dev/null +++ b/extra/mason/report/fake-data/help-lint-time @@ -0,0 +1 @@ +1234 diff --git a/extra/mason/report/fake-data/help-lint-vocabs b/extra/mason/report/fake-data/help-lint-vocabs new file mode 100644 index 0000000000..6d88a7fff8 --- /dev/null +++ b/extra/mason/report/fake-data/help-lint-vocabs @@ -0,0 +1 @@ +{ "help-lint" } diff --git a/extra/mason/report/fake-data/html-help-time b/extra/mason/report/fake-data/html-help-time new file mode 100644 index 0000000000..81c545efeb --- /dev/null +++ b/extra/mason/report/fake-data/html-help-time @@ -0,0 +1 @@ +1234 diff --git a/extra/mason/report/fake-data/load-everything-errors b/extra/mason/report/fake-data/load-everything-errors new file mode 100644 index 0000000000..00d830932d --- /dev/null +++ b/extra/mason/report/fake-data/load-everything-errors @@ -0,0 +1 @@ +Load everything diff --git a/extra/mason/report/fake-data/load-everything-vocabs b/extra/mason/report/fake-data/load-everything-vocabs new file mode 100644 index 0000000000..2ecd4f611c --- /dev/null +++ b/extra/mason/report/fake-data/load-everything-vocabs @@ -0,0 +1 @@ +{ "load-everything" } diff --git a/extra/mason/report/fake-data/load-time b/extra/mason/report/fake-data/load-time new file mode 100644 index 0000000000..81c545efeb --- /dev/null +++ b/extra/mason/report/fake-data/load-time @@ -0,0 +1 @@ +1234 diff --git a/extra/mason/report/fake-data/test-all-errors b/extra/mason/report/fake-data/test-all-errors new file mode 100644 index 0000000000..13a64ee834 --- /dev/null +++ b/extra/mason/report/fake-data/test-all-errors @@ -0,0 +1 @@ +Test all errors diff --git a/extra/mason/report/fake-data/test-all-vocabs b/extra/mason/report/fake-data/test-all-vocabs new file mode 100644 index 0000000000..ef6294b9c7 --- /dev/null +++ b/extra/mason/report/fake-data/test-all-vocabs @@ -0,0 +1 @@ +{ "test-all" } diff --git a/extra/mason/report/fake-data/test-log b/extra/mason/report/fake-data/test-log new file mode 100644 index 0000000000..0b8521b008 --- /dev/null +++ b/extra/mason/report/fake-data/test-log @@ -0,0 +1,2 @@ +Test +Log diff --git a/extra/mason/report/fake-data/test-time b/extra/mason/report/fake-data/test-time new file mode 100644 index 0000000000..81c545efeb --- /dev/null +++ b/extra/mason/report/fake-data/test-time @@ -0,0 +1 @@ +1234 diff --git a/extra/mason/report/report-tests.factor b/extra/mason/report/report-tests.factor index a9e8e2802b..92cada72da 100644 --- a/extra/mason/report/report-tests.factor +++ b/extra/mason/report/report-tests.factor @@ -1,4 +1,28 @@ IN: mason.report.tests -USING: mason.report tools.test ; +USING: io.files io.directories kernel mason.report mason.common +tools.test xml xml.writer ; -{ 0 0 } [ [ ] with-report ] must-infer-as \ No newline at end of file +{ 0 0 } [ [ ] with-report ] must-infer-as + +: verify-report ( -- ) + [ t ] [ "report" exists? ] unit-test + [ ] [ "report" file>xml drop ] unit-test + [ ] [ "report" delete-file ] unit-test ; + +"resource:extra/mason/report/fake-data/" [ + [ ] [ + timings-table pprint-xml + ] unit-test + + [ ] [ successful-report ] unit-test + verify-report + + [ status-error ] [ 1234 compile-failed ] unit-test + verify-report + + [ status-error ] [ 1235 boot-failed ] unit-test + verify-report + + [ status-error ] [ 1236 test-failed ] unit-test + verify-report +] with-directory diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 0839652d55..eb00107d21 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -3,7 +3,8 @@ USING: benchmark combinators.smart debugger fry io assocs io.encodings.utf8 io.files io.sockets io.streams.string kernel locals mason.common mason.config mason.platform math namespaces -prettyprint sequences xml.syntax xml.writer combinators.short-circuit ; +prettyprint sequences xml.syntax xml.writer combinators.short-circuit +literals ; IN: mason.report : common-report ( -- xml ) @@ -56,15 +57,14 @@ IN: mason.report : timings-table ( -- xml ) { - boot-time-file - load-time-file - test-time-file - help-lint-time-file - benchmark-time-file - html-help-time-file + $ boot-time-file + $ load-time-file + $ test-time-file + $ help-lint-time-file + $ benchmark-time-file + $ html-help-time-file } [ - execute( -- string ) - dup utf8 file-contents milli-seconds>time + dup eval-file milli-seconds>time [XML <-><-> XML] ] map [XML

Timings

<->
XML] ; From 5165d811d5dddee055aa5fe5641ccee1e5376965 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 04:21:00 -0500 Subject: [PATCH 49/98] Changing the stack effect of a generic word could break the compiler --- basis/compiler/tests/redefine16.factor | 10 ++++++ .../compiler/tree/optimizer/optimizer.factor | 12 ++++--- .../known-words/known-words.factor | 2 ++ core/words/words.factor | 36 ++++++++++--------- 4 files changed, 40 insertions(+), 20 deletions(-) create mode 100644 basis/compiler/tests/redefine16.factor diff --git a/basis/compiler/tests/redefine16.factor b/basis/compiler/tests/redefine16.factor new file mode 100644 index 0000000000..e0bb1773c9 --- /dev/null +++ b/basis/compiler/tests/redefine16.factor @@ -0,0 +1,10 @@ +IN: compiler.tests.redefine16 +USING: eval tools.test definitions words compiler.units +quotations stack-checker ; + +[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test + +[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test +[ "blah" "compiler.tests.redefine16" lookup 1quotation infer ] must-fail diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index 54c6c2c117..daa8f072ca 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -18,11 +18,18 @@ IN: compiler.tree.optimizer SYMBOL: check-optimizer? +: ?check ( nodes -- nodes' ) + check-optimizer? get [ + compute-def-use + dup check-nodes + ] when ; + : optimize-tree ( nodes -- nodes' ) analyze-recursive normalize propagate cleanup + ?check dup run-escape-analysis? [ escape-analysis unbox-tuples @@ -30,10 +37,7 @@ SYMBOL: check-optimizer? apply-identities compute-def-use remove-dead-code - check-optimizer? get [ - compute-def-use - dup check-nodes - ] when + ?check compute-def-use optimize-modular-arithmetic finalize ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index ff7288202a..abc1f68bb6 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -218,6 +218,8 @@ M: object infer-call* alien-callback } [ t "special" set-word-prop ] each +M\ quotation call t "no-compile" set-word-prop +M\ word execute t "no-compile" set-word-prop \ clear t "no-compile" set-word-prop : non-inline-word ( word -- ) diff --git a/core/words/words.factor b/core/words/words.factor index 5b230c1b00..c388f093fd 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -68,10 +68,6 @@ M: word crossref? vocabulary>> >boolean ] if ; -GENERIC: compiled-crossref? ( word -- ? ) - -M: word compiled-crossref? crossref? ; - GENERIC# (quot-uses) 1 ( obj assoc -- ) M: object (quot-uses) 2drop ; @@ -131,26 +127,38 @@ compiled-generic-crossref [ H{ } clone ] initialize : inline? ( word -- ? ) "inline" word-prop ; inline +GENERIC: subwords ( word -- seq ) + +M: word subwords drop f ; + + + : redefined ( word -- ) [ H{ } clone visited [ (redefined) ] with-variable ] [ changed-definition ] @@ -199,10 +207,6 @@ M: word reset-word "writer" "delimiter" } reset-props ; -GENERIC: subwords ( word -- seq ) - -M: word subwords drop f ; - : reset-generic ( word -- ) [ subwords forget-all ] [ reset-word ] From 74d352434c02faef127f884b241af6b3205f9158 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 04:25:11 -0500 Subject: [PATCH 50/98] morse: fix help lint --- extra/morse/morse-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/morse/morse-docs.factor b/extra/morse/morse-docs.factor index 93350ad02d..e2fab1528b 100644 --- a/extra/morse/morse-docs.factor +++ b/extra/morse/morse-docs.factor @@ -5,7 +5,7 @@ IN: morse HELP: ch>morse { $values - { "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } } + { "ch" "A character that has a morse code translation" } { "morse" "A string consisting of zero or more dots and dashes" } } { $description "If the given character has a morse code translation, then return that translation, otherwise return a ? character." } ; HELP: morse>ch @@ -15,12 +15,12 @@ HELP: morse>ch HELP: >morse { $values - { "str" "A string of ASCII characters which can be translated into morse code" } { "str" "A string in morse code" } } + { "str" "A string of ASCII characters which can be translated into morse code" } { "newstr" "A string in morse code" } } { $description "Translates ASCII text into morse code, represented by a series of dots, dashes, and slashes." } { $see-also morse> ch>morse } ; HELP: morse> -{ $values { "str" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "str" "The ASCII translation of the given string" } } +{ $values { "morse" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "plain" "The ASCII translation of the given string" } } { $description "Translates morse code into ASCII text" } { $see-also >morse morse>ch } ; From 5c236d6585afe7751263ca4d9c74722ef6e17ea7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 16:52:18 -0500 Subject: [PATCH 51/98] add a size-on-disk slot to file-info, the each-file combinator now works better, add a path>sizes word --- basis/io/directories/search/search.factor | 44 +++++++++++++++++----- basis/io/files/info/info.factor | 4 +- basis/io/files/info/unix/unix.factor | 1 + basis/io/files/info/windows/windows.factor | 28 +++++++++++++- basis/windows/kernel32/kernel32.factor | 3 +- 5 files changed, 66 insertions(+), 14 deletions(-) diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 6db83ebca6..38d8ec957e 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays continuations deques dlists fry io.directories io.files io.files.info io.pathnames kernel -sequences system vocabs.loader ; +sequences system vocabs.loader locals math namespaces +sorting assocs ; IN: io.directories.search > ] [ bfs>> ] bi + [ qualified-directory ] dip '[ + _ [ queue>> ] [ bfs>> ] bi [ push-front ] [ push-back ] if - ] curry each ; + ] each ; : ( path bfs? -- iterator ) directory-iterator boa @@ -28,12 +29,11 @@ TUPLE: directory-iterator path bfs queue ; [ over push-directory next-file ] [ nip ] if ] if ; -: iterate-directory ( iter quot: ( obj -- ? ) -- obj ) - over next-file [ - over call - [ 2nip ] [ iterate-directory ] if* +:: iterate-directory ( iter quot: ( obj -- ? ) -- obj ) + iter next-file [ + quot call [ iter quot iterate-directory ] unless* ] [ - 2drop f + f ] if* ; inline recursive PRIVATE> @@ -70,4 +70,30 @@ ERROR: file-not-found ; : find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f ) '[ _ _ find-all-files ] map concat ; inline +: with-qualified-directory-files ( path quot -- ) + '[ + "" directory-files current-directory get + '[ _ prepend-path ] map @ + ] with-directory ; inline + +: with-qualified-directory-entries ( path quot -- ) + '[ + "" directory-entries current-directory get + '[ [ _ prepend-path ] change-name ] map @ + ] with-directory ; inline + +: directory-size ( path -- n ) + 0 swap t [ file-info size-on-disk>> + ] each-file ; + +: path>sizes ( path -- assoc ) + [ + [ + [ name>> dup ] [ directory? ] bi [ + directory-size + ] [ + file-info size-on-disk>> + ] if + ] { } map>assoc + ] with-qualified-directory-entries sort-values ; + os windows? [ "io.directories.search.windows" require ] when diff --git a/basis/io/files/info/info.factor b/basis/io/files/info/info.factor index fd21850612..5c5d2c93d2 100644 --- a/basis/io/files/info/info.factor +++ b/basis/io/files/info/info.factor @@ -5,7 +5,7 @@ vocabs.loader io.files.types ; IN: io.files.info ! File info -TUPLE: file-info type size permissions created modified +TUPLE: file-info type size size-on-disk permissions created modified accessed ; HOOK: file-info os ( path -- info ) @@ -25,4 +25,4 @@ HOOK: file-system-info os ( path -- file-system-info ) { { [ os unix? ] [ "io.files.info.unix." os name>> append ] } { [ os windows? ] [ "io.files.info.windows" ] } -} cond require \ No newline at end of file +} cond require diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index 616f70cccc..d4762a536d 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -80,6 +80,7 @@ M: unix stat>file-info ( stat -- file-info ) [ stat-st_rdev >>rdev ] [ stat-st_blocks >>blocks ] [ stat-st_blksize >>blocksize ] + [ drop blocks>> blocksize>> * >>size-on-disk ] } cleave ; : n>file-type ( n -- type ) diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index fdff368491..81e43f8dd9 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -5,11 +5,33 @@ io.files.windows io.files.windows.nt kernel windows.kernel32 windows.time windows accessors alien.c-types combinators generalizations system alien.strings io.encodings.utf16n sequences splitting windows.errors fry continuations destructors -calendar ascii combinators.short-circuit ; +calendar ascii combinators.short-circuit locals ; IN: io.files.info.windows +:: round-up-to ( n multiple -- n' ) + n multiple rem dup 0 = [ + drop n + ] [ + multiple swap - n + + ] if ; + TUPLE: windows-file-info < file-info attributes ; +: get-compressed-file-size ( path -- n ) + "DWORD" [ GetCompressedFileSize ] keep + over INVALID_FILE_SIZE = [ + win32-error-string throw + ] [ + *uint >64bit + ] if ; + +: set-windows-size-on-disk ( file-info path -- file-info ) + over attributes>> +compressed+ swap member? [ + get-compressed-file-size + ] [ + drop dup size>> 4096 round-up-to + ] if >>size-on-disk ; + : WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info ) [ \ windows-file-info new ] dip { @@ -79,7 +101,9 @@ TUPLE: windows-file-info < file-info attributes ; ] if ; M: windows file-info ( path -- info ) - normalize-path get-file-information-stat ; + normalize-path + [ get-file-information-stat ] + [ set-windows-size-on-disk ] bi ; M: windows link-info ( path -- info ) file-info ; diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 4d3dd81a0e..1a513df186 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -1139,7 +1139,8 @@ FUNCTION: BOOL GetCommState ( HANDLE hFile, LPDCB lpDCB ) ; ! FUNCTION: GetCommTimeouts ! FUNCTION: GetComPlusPackageInstallStatus ! FUNCTION: GetCompressedFileSizeA -! FUNCTION: GetCompressedFileSizeW +FUNCTION: DWORD GetCompressedFileSizeW ( LPCTSTR lpFileName, LPDWORD lpFileSizeHigh ) ; +ALIAS: GetCompressedFileSize GetCompressedFileSizeW FUNCTION: BOOL GetComputerNameW ( LPTSTR lpBuffer, LPDWORD lpnSize ) ; ALIAS: GetComputerName GetComputerNameW FUNCTION: BOOL GetComputerNameExW ( COMPUTER_NAME_FORMAT NameType, LPTSTR lpBuffer, LPDWORD lpnSize ) ; From 12a89f15500cc5ff9b6a7fcdf08ede7e8ce391ca Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 17:25:18 -0500 Subject: [PATCH 52/98] fix size-on-disk for unix --- basis/io/files/info/unix/unix.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index d4762a536d..11fa3130d1 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -80,7 +80,7 @@ M: unix stat>file-info ( stat -- file-info ) [ stat-st_rdev >>rdev ] [ stat-st_blocks >>blocks ] [ stat-st_blksize >>blocksize ] - [ drop blocks>> blocksize>> * >>size-on-disk ] + [ drop dup [ blocks>> ] [ blocksize>> ] bi * >>size-on-disk ] } cleave ; : n>file-type ( n -- type ) From bd6eb42d0f48b412228dbc073ac4a31bdacd9f7a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 17:44:12 -0500 Subject: [PATCH 53/98] fix size-on-disk for unix --- basis/io/files/info/unix/unix.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index 11fa3130d1..80f4b74ac8 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -63,6 +63,8 @@ M: unix link-info ( path -- info ) M: unix new-file-info ( -- class ) unix-file-info new ; +CONSTANT: standard-unix-block-size 512 + M: unix stat>file-info ( stat -- file-info ) [ new-file-info ] dip { @@ -80,7 +82,7 @@ M: unix stat>file-info ( stat -- file-info ) [ stat-st_rdev >>rdev ] [ stat-st_blocks >>blocks ] [ stat-st_blksize >>blocksize ] - [ drop dup [ blocks>> ] [ blocksize>> ] bi * >>size-on-disk ] + [ drop dup blocks>> standard-unix-block-size * >>size-on-disk ] } cleave ; : n>file-type ( n -- type ) From bf0b1e63c812a2eb835165de55d93d0d19cd2e78 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 17:50:26 -0500 Subject: [PATCH 54/98] use link-info instead of file-info --- basis/io/directories/search/search.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 38d8ec957e..236da09489 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -83,15 +83,15 @@ ERROR: file-not-found ; ] with-directory ; inline : directory-size ( path -- n ) - 0 swap t [ file-info size-on-disk>> + ] each-file ; + 0 swap t [ link-info size-on-disk>> + ] each-file ; -: path>sizes ( path -- assoc ) +: directory-usage ( path -- assoc ) [ [ [ name>> dup ] [ directory? ] bi [ directory-size ] [ - file-info size-on-disk>> + link-info size-on-disk>> ] if ] { } map>assoc ] with-qualified-directory-entries sort-values ; From f73a29c1a52cc616506c8b6f5b21560044b1b2d5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 18:37:23 -0500 Subject: [PATCH 55/98] README.txt: don't mention GLUT --- README.txt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.txt b/README.txt index c5d53de842..c0d56dfa09 100755 --- a/README.txt +++ b/README.txt @@ -59,10 +59,10 @@ On Unix, Factor can either run a graphical user interface using X11, or a terminal listener. For X11 support, you need recent development libraries for libc, -Pango, X11, OpenGL and GLUT. On a Debian-derived Linux distribution +Pango, X11, and OpenGL. On a Debian-derived Linux distribution (like Ubuntu), you can use the following line to grab everything: - sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev glutg3-dev + sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev If your DISPLAY environment variable is set, the UI will start automatically: From 84146931429d31e7faff586f3e4476eddb73751e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 18:44:45 -0500 Subject: [PATCH 56/98] stack-checker: trust word declarations instead of recursively checking them --- basis/compiler/compiler.factor | 3 +- basis/compiler/tree/builder/builder.factor | 54 +++++++-------- .../tree/propagation/inlining/inlining.factor | 38 ++++++---- basis/hints/hints.factor | 2 +- basis/prettyprint/prettyprint-tests.factor | 1 - basis/stack-checker/backend/backend.factor | 69 ++++--------------- .../call-effect/call-effect.factor | 8 ++- basis/stack-checker/errors/errors.factor | 4 ++ .../known-words/known-words.factor | 7 +- .../recursive-state/recursive-state.factor | 25 ++----- basis/stack-checker/stack-checker-docs.factor | 9 --- .../stack-checker/stack-checker-tests.factor | 4 ++ basis/stack-checker/stack-checker.factor | 13 ---- basis/stack-checker/state/state.factor | 3 - .../transforms/transforms.factor | 28 +++++--- basis/tools/deploy/shaker/shaker.factor | 2 - core/classes/classes.factor | 2 +- core/classes/tuple/tuple.factor | 2 +- core/words/words-docs.factor | 4 -- core/words/words.factor | 37 +--------- 20 files changed, 114 insertions(+), 201 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index e5d88af14a..7c53e41377 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -57,7 +57,6 @@ SYMBOLS: +optimized+ +unoptimized+ ; { [ inline? ] [ macro? ] - [ "transform-quot" word-prop ] [ "no-compile" word-prop ] [ "special" word-prop ] } 1|| @@ -150,4 +149,4 @@ M: optimizing-compiler recompile ( words -- alist ) f compiler-impl set-global ; : recompile-all ( -- ) - forget-errors all-words compile ; + all-words compile ; diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index fe9c2a26a4..edea9ae6c0 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors quotations kernel sequences namespaces -assocs words arrays vectors hints combinators compiler.tree +assocs words arrays vectors hints combinators continuations +effects compiler.tree stack-checker stack-checker.state stack-checker.errors @@ -15,23 +16,27 @@ IN: compiler.tree.builder with-infer nip ; inline : build-tree ( quot -- nodes ) - #! Not safe to call from inference transforms. [ f initial-recursive-state infer-quot ] with-tree-builder ; : build-tree-with ( in-stack quot -- nodes out-stack ) - #! Not safe to call from inference transforms. [ - [ >vector \ meta-d set ] - [ f initial-recursive-state infer-quot ] bi* - ] with-tree-builder - unclip-last in-d>> ; + [ + [ >vector \ meta-d set ] + [ f initial-recursive-state infer-quot ] bi* + ] with-tree-builder + unclip-last in-d>> + ] [ "OOPS" USE: io print flush 3drop f f ] recover ; -: build-sub-tree ( #call quot -- nodes ) +: build-sub-tree ( #call quot -- nodes/f ) [ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with - over ends-with-terminate? - [ drop swap [ f swap #push ] map append ] - [ rot #copy suffix ] - if ; + { + { [ over not ] [ 3drop f ] } + { [ over ends-with-terminate? ] [ drop swap [ f swap #push ] map append ] } + [ rot #copy suffix ] + } cond ; + +: check-no-compile ( word -- ) + dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ; : (build-tree-from-word) ( word -- ) dup initial-recursive-state recursive-state set @@ -39,24 +44,19 @@ IN: compiler.tree.builder [ 1quotation ] [ specialized-def ] if infer-quot-here ; -: check-cannot-infer ( word -- ) - dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ; +: check-effect ( word effect -- ) + over required-stack-effect 2dup effect<= + [ 3drop ] [ effect-error ] if ; -TUPLE: do-not-compile word ; - -: check-no-compile ( word -- ) - dup "no-compile" word-prop [ do-not-compile inference-warning ] [ drop ] if ; +: finish-word ( word -- ) + current-effect check-effect ; : build-tree-from-word ( word -- nodes ) [ - [ - { - [ check-cannot-infer ] - [ check-no-compile ] - [ (build-tree-from-word) ] - [ finish-word ] - } cleave - ] maybe-cannot-infer + [ check-no-compile ] + [ (build-tree-from-word) ] + [ finish-word ] + tri ] with-tree-builder ; : contains-breakpoints? ( word -- ? ) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 7ae44a5293..b26ce3bed9 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -4,6 +4,7 @@ USING: accessors kernel arrays sequences math math.order math.partial-dispatch generic generic.standard generic.math classes.algebra classes.union sets quotations assocs combinators words namespaces continuations classes fry combinators.smart hints +locals compiler.tree compiler.tree.builder compiler.tree.recursive @@ -27,24 +28,30 @@ SYMBOL: node-count SYMBOL: inlining-count ! Splicing nodes -GENERIC: splicing-nodes ( #call word/quot/f -- nodes ) +GENERIC: splicing-nodes ( #call word/quot/f -- nodes/f ) M: word splicing-nodes [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; M: callable splicing-nodes - build-sub-tree analyze-recursive normalize ; + build-sub-tree dup [ analyze-recursive normalize ] when ; ! Dispatch elimination +: undo-inlining ( #call -- ? ) + f >>method f >>body f >>class drop f ; + +: propagate-body ( #call -- ? ) + body>> (propagate) t ; + : eliminate-dispatch ( #call class/f word/quot/f -- ? ) dup [ [ >>class ] dip - over method>> over = [ drop ] [ - 2dup splicing-nodes - [ >>method ] [ >>body ] bi* + over method>> over = [ drop propagate-body ] [ + 2dup splicing-nodes dup [ + [ >>method ] [ >>body ] bi* propagate-body + ] [ 2drop undo-inlining ] if ] if - body>> (propagate) t - ] [ 2drop f >>method f >>body f >>class drop f ] if ; + ] [ 2drop undo-inlining ] if ; : inlining-standard-method ( #call word -- class/f method/f ) dup "methods" word-prop assoc-empty? [ 2drop f f ] [ @@ -159,14 +166,15 @@ SYMBOL: history [ history [ swap suffix ] change ] bi ; -: inline-word-def ( #call word quot -- ? ) - over history get memq? [ 3drop f ] [ - [ - [ remember-inlining ] dip - [ drop ] [ splicing-nodes ] 2bi - [ >>body drop ] [ count-nodes ] [ (propagate) ] tri - ] with-scope node-count +@ - t +:: inline-word-def ( #call word quot -- ? ) + word history get memq? [ f ] [ + #call quot splicing-nodes [ + [ + word remember-inlining + [ ] [ count-nodes ] [ (propagate) ] tri + ] with-scope + [ #call (>>body) ] [ node-count +@ ] bi* t + ] [ f ] if* ] if ; : inline-word ( #call word -- ? ) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index d44bf92bf4..ed55c1c332 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -65,7 +65,7 @@ M: object specializer-declaration class ; SYNTAX: HINTS: scan-object - [ redefined ] + [ changed-definition ] [ parse-definition "specializer" set-word-prop ] bi ; ! Default specializers diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index a660d4a311..25ee83985e 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -86,7 +86,6 @@ unit-test drop ; [ "drop ;" ] [ - \ blah f "inferred-effect" set-word-prop [ \ blah see ] with-string-writer "\n" ?tail drop 6 tail* ] unit-test diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 9e867f4fbb..ed9c01b06c 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry arrays generic io io.streams.string kernel math namespaces parser sequences strings vectors words quotations effects classes continuations assocs combinators compiler.errors accessors math.order definitions sets -generic.standard.engines.tuple hints stack-checker.state +generic.standard.engines.tuple hints macros stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state ; IN: stack-checker.backend @@ -121,9 +121,6 @@ M: object apply-object push-literal ; : infer-r> ( n -- ) consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ; -: undo-infer ( -- ) - recorded get [ f "inferred-effect" set-word-prop ] each ; - : (consume/produce) ( effect -- inputs outputs ) [ in>> length consume-d ] [ out>> length produce-d ] bi ; @@ -132,65 +129,29 @@ M: object apply-object push-literal ; [ terminated?>> [ terminate ] when ] bi ; inline -: infer-word-def ( word -- ) - [ specialized-def ] [ add-recursive-state ] bi infer-quot ; - : end-infer ( -- ) meta-d clone #return, ; : required-stack-effect ( word -- effect ) dup stack-effect [ ] [ missing-effect ] ?if ; -: check-effect ( word effect -- ) - over required-stack-effect 2dup effect<= - [ 3drop ] [ effect-error ] if ; - -: finish-word ( word -- ) - [ current-effect check-effect ] - [ recorded get push ] - [ t "inferred-effect" set-word-prop ] - tri ; - -: cannot-infer-effect ( word -- * ) - "cannot-infer" word-prop rethrow ; - -: maybe-cannot-infer ( word quot -- ) - [ [ "cannot-infer" set-word-prop ] keep rethrow ] recover ; inline - -: infer-word ( word -- effect ) - [ - [ - init-inference - init-known-values - stack-visitor off - dependencies off - generic-dependencies off - [ infer-word-def end-infer ] - [ finish-word ] - [ stack-effect ] - tri - ] with-scope - ] maybe-cannot-infer ; - : apply-word/effect ( word effect -- ) swap '[ _ #call, ] consume/produce ; -: call-recursive-word ( word -- ) - dup required-stack-effect apply-word/effect ; - -: cached-infer ( word -- ) - dup stack-effect apply-word/effect ; +: infer-word ( word -- ) + { + { [ dup macro? ] [ do-not-compile ] } + { [ dup "no-compile" word-prop ] [ do-not-compile ] } + [ dup required-stack-effect apply-word/effect ] + } cond ; : with-infer ( quot -- effect visitor ) [ - [ - V{ } clone recorded set - init-inference - init-known-values - stack-visitor off - call - end-infer - current-effect - stack-visitor get - ] [ ] [ undo-infer ] cleanup + init-inference + init-known-values + stack-visitor off + call + end-infer + current-effect + stack-visitor get ] with-scope ; inline diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/stack-checker/call-effect/call-effect.factor index bd1f7c73c3..100088f174 100644 --- a/basis/stack-checker/call-effect/call-effect.factor +++ b/basis/stack-checker/call-effect/call-effect.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators combinators.private effects fry kernel kernel.private make sequences continuations quotations -stack-checker stack-checker.transforms ; +stack-checker stack-checker.transforms words ; IN: stack-checker.call-effect ! call( and execute( have complex expansions. @@ -54,6 +54,8 @@ M: quotation cached-effect \ call-effect-slow [ call-effect-slow>quot ] 1 define-transform +\ call-effect-slow t "no-compile" set-word-prop + : call-effect-fast ( quot effect inline-cache -- ) 2over call-effect-unsafe? [ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ] @@ -71,6 +73,8 @@ M: quotation cached-effect ] ] 0 define-transform +\ call-effect t "no-compile" set-word-prop + : execute-effect-slow ( word effect -- ) [ '[ _ execute ] ] dip call-effect-slow ; inline @@ -93,3 +97,5 @@ M: quotation cached-effect inline-cache new '[ _ _ execute-effect-ic ] ; \ execute-effect [ execute-effect>quot ] 1 define-transform + +\ execute-effect t "no-compile" set-word-prop \ No newline at end of file diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index 156900f727..cb45d65954 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -24,6 +24,10 @@ M: inference-error error-type type>> ; : inference-warning ( ... class -- * ) +compiler-warning+ (inference-error) ; inline +TUPLE: do-not-compile word ; + +: do-not-compile ( word -- * ) \ do-not-compile inference-warning ; + TUPLE: literal-expected what ; : literal-expected ( what -- * ) \ literal-expected inference-warning ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index abc1f68bb6..85aa9030f8 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -219,6 +219,8 @@ M: object infer-call* } [ t "special" set-word-prop ] each M\ quotation call t "no-compile" set-word-prop +M\ curry call t "no-compile" set-word-prop +M\ compose call t "no-compile" set-word-prop M\ word execute t "no-compile" set-word-prop \ clear t "no-compile" set-word-prop @@ -230,14 +232,11 @@ M\ word execute t "no-compile" set-word-prop { [ dup "primitive" word-prop ] [ infer-primitive ] } { [ dup "transform-quot" word-prop ] [ apply-transform ] } { [ dup "macro" word-prop ] [ apply-macro ] } - { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] } - { [ dup "inferred-effect" word-prop ] [ cached-infer ] } { [ dup local? ] [ infer-local-reader ] } { [ dup local-reader? ] [ infer-local-reader ] } { [ dup local-writer? ] [ infer-local-writer ] } { [ dup local-word? ] [ infer-local-word ] } - { [ dup recursive-word? ] [ call-recursive-word ] } - [ dup infer-word apply-word/effect ] + [ infer-word ] } cond ; : define-primitive ( word inputs outputs -- ) diff --git a/basis/stack-checker/recursive-state/recursive-state.factor b/basis/stack-checker/recursive-state/recursive-state.factor index 9abfb1fcd5..7740bebf4c 100644 --- a/basis/stack-checker/recursive-state/recursive-state.factor +++ b/basis/stack-checker/recursive-state/recursive-state.factor @@ -1,39 +1,26 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays sequences kernel sequences assocs namespaces stack-checker.recursive-state.tree ; IN: stack-checker.recursive-state -TUPLE: recursive-state word words quotations inline-words ; - -: prepare-recursive-state ( word rstate -- rstate ) - swap >>word - f >>quotations - f >>inline-words ; inline +TUPLE: recursive-state word quotations inline-words ; : initial-recursive-state ( word -- state ) recursive-state new - f >>words - prepare-recursive-state ; inline + swap >>word + f >>quotations + f >>inline-words ; inline f initial-recursive-state recursive-state set-global -: add-recursive-state ( word -- rstate ) - recursive-state get clone - [ word>> dup ] keep [ store ] change-words - prepare-recursive-state ; - -: add-local-quotation ( recursive-state quot -- rstate ) +: add-local-quotation ( rstate quot -- rstate ) swap clone [ dupd store ] change-quotations ; : add-inline-word ( word label -- rstate ) swap recursive-state get clone [ store ] change-inline-words ; -: recursive-word? ( word -- ? ) - recursive-state get 2dup word>> eq? - [ 2drop t ] [ words>> lookup ] if ; - : inline-recursive-label ( word -- label/f ) recursive-state get inline-words>> lookup ; diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 28090918bb..78196abfba 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -109,7 +109,6 @@ HELP: inference-error "The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "." } ; - HELP: infer { $values { "quot" "a quotation" } { "effect" "an instance of " { $link effect } } } { $description "Attempts to infer the quotation's stack effect. For interactive testing, the " { $link infer. } " word should be called instead since it presents the output in a nicely formatted manner." } @@ -121,11 +120,3 @@ HELP: infer. { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; { infer infer. } related-words - -HELP: forget-errors -{ $description "Removes markers indicating which words do not have stack effects." -$nl -"The stack effect inference code remembers which words failed to infer as an optimization, so that it does not try to infer the stack effect of words which do not have one over and over again." } -{ $notes "Usually this word does not need to be called directly; if a word failed to compile because of a stack effect error, fixing the word definition clears the flag automatically. However, if words failed to compile due to external factors which were subsequently rectified, such as an unavailable C library or a missing or broken compiler transform, this flag can be cleared for all words:" -{ $code "forget-errors" } -"Subsequent invocations of the compiler will consider all words for compilation." } ; diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 6b9e9fd8b6..6ac4fce0c0 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -588,3 +588,7 @@ DEFER: eee' [ forget-test ] must-infer [ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test [ forget-test ] must-infer + +[ [ cond ] infer ] must-fail +[ [ bi ] infer ] must-fail +[ at ] must-infer \ No newline at end of file diff --git a/basis/stack-checker/stack-checker.factor b/basis/stack-checker/stack-checker.factor index e18a6f0840..759988a61f 100644 --- a/basis/stack-checker/stack-checker.factor +++ b/basis/stack-checker/stack-checker.factor @@ -16,17 +16,4 @@ M: callable infer ( quot -- effect ) #! Safe to call from inference transforms. infer effect>string print ; -: forget-errors ( -- ) - all-words [ - dup subwords [ f "cannot-infer" set-word-prop ] each - f "cannot-infer" set-word-prop - ] each ; - -: forget-effects ( -- ) - forget-errors - all-words [ - dup subwords [ f "inferred-effect" set-word-prop ] each - f "inferred-effect" set-word-prop - ] each ; - "stack-checker.call-effect" require \ No newline at end of file diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 6ae12dbd0c..a76d302a7e 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -64,6 +64,3 @@ SYMBOL: generic-dependencies : depends-on-generic ( generic class -- ) generic-dependencies get dup [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ; - -! Words we've inferred the stack effect of, for rollback -SYMBOL: recorded diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index fd62c4998d..2e66d7d728 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -10,13 +10,6 @@ stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state ; IN: stack-checker.transforms -: give-up-transform ( word -- ) - { - { [ dup "inferred-effect" word-prop ] [ cached-infer ] } - { [ dup recursive-word? ] [ call-recursive-word ] } - [ dup infer-word apply-word/effect ] - } cond ; - : call-transformer ( word stack quot -- newquot ) '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ] [ transform-expansion-error ] @@ -29,7 +22,7 @@ IN: stack-checker.transforms word inlined-dependency depends-on values [ length meta-d shorten-by ] [ #drop, ] bi rstate infer-quot - ] [ word give-up-transform ] if* ; + ] [ word infer-word ] if* ; : literals? ( values -- ? ) [ literal-value? ] all? ; @@ -41,7 +34,7 @@ IN: stack-checker.transforms [ first literal recursion>> ] tri ] if ((apply-transform)) - ] [ 2drop give-up-transform ] if ; + ] [ 2drop infer-word ] if ; : apply-transform ( word -- ) [ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri @@ -59,6 +52,8 @@ IN: stack-checker.transforms ! Combinators \ cond [ cond>quot ] 1 define-transform +\ cond t "no-compile" set-word-prop + \ case [ [ [ no-case ] @@ -71,14 +66,24 @@ IN: stack-checker.transforms ] if-empty ] 1 define-transform +\ case t "no-compile" set-word-prop + \ cleave [ cleave>quot ] 1 define-transform +\ cleave t "no-compile" set-word-prop + \ 2cleave [ 2cleave>quot ] 1 define-transform +\ 2cleave t "no-compile" set-word-prop + \ 3cleave [ 3cleave>quot ] 1 define-transform +\ 3cleave t "no-compile" set-word-prop + \ spread [ spread>quot ] 1 define-transform +\ spread t "no-compile" set-word-prop + \ (call-next-method) [ [ [ "method-class" word-prop ] @@ -90,6 +95,8 @@ IN: stack-checker.transforms ] bi ] 1 define-transform +\ (call-next-method) t "no-compile" set-word-prop + ! Constructors \ boa [ dup tuple-class? [ @@ -100,6 +107,9 @@ IN: stack-checker.transforms ] [ drop f ] if ] 1 define-transform +\ boa t "no-compile" set-word-prop +M\ tuple-class boa t "no-compile" set-word-prop + \ new [ dup tuple-class? [ dup inlined-dependency depends-on diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index ba0daf6056..807abe4d58 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -97,7 +97,6 @@ IN: tools.deploy.shaker { "alias" "boa-check" - "cannot-infer" "coercer" "combination" "compiled-status" @@ -116,7 +115,6 @@ IN: tools.deploy.shaker "identities" "if-intrinsics" "infer" - "inferred-effect" "inline" "inlined-block" "input-classes" diff --git a/core/classes/classes.factor b/core/classes/classes.factor index ab8ba398cd..dfaec95f76 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -135,7 +135,7 @@ M: sequence implementors [ implementors ] gather ; [ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ] [ reset-class ] [ ?define-symbol ] - [ redefined ] + [ changed-definition ] [ ] } cleave ] dip [ assoc-union ] curry change-props diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index fb7a073205..fb1e613b3e 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -243,7 +243,7 @@ M: tuple-class update-class 2drop [ [ update-tuples-after ] - [ redefined ] + [ changed-definition ] bi ] each-subclass ] diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index c20ee66de8..4bed65374c 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -104,10 +104,6 @@ $nl { { { $snippet "\"help\"" } ", " { $snippet "\"help-loc\"" } ", " { $snippet "\"help-parent\"" } } { "Where word help is stored - " { $link "writing-help" } } } - { { $snippet "\"infer\"" } { $link "macros" } } - - { { { $snippet "\"inferred-effect\"" } } { $link "inference" } } - { { $snippet "\"specializer\"" } { $link "hints" } } { { $snippet "\"predicating\"" } " Set on class predicates, stores the corresponding class word" } diff --git a/core/words/words.factor b/core/words/words.factor index c388f093fd..97225c0f75 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -131,43 +131,10 @@ GENERIC: subwords ( word -- seq ) M: word subwords drop f ; - - -: redefined ( word -- ) - [ H{ } clone visited [ (redefined) ] with-variable ] - [ changed-definition ] - bi ; - : define ( word def -- ) [ ] like over unxref - over redefined + over changed-definition >>def dup crossref? [ dup xref ] when drop ; @@ -176,7 +143,7 @@ PRIVATE> swap [ drop changed-effect ] [ "declared-effect" set-word-prop ] - [ drop dup primitive? [ drop ] [ redefined ] if ] + [ drop dup primitive? [ drop ] [ changed-definition ] if ] 2tri ] if ; From 3af8f7fba128fc6781c45a7053cd5ba203e8aeb9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 19:11:07 -0500 Subject: [PATCH 57/98] search for emacs.exe on windows by default --- basis/editors/emacs/emacs.factor | 5 ++++- basis/editors/emacs/windows/windows.factor | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/basis/editors/emacs/emacs.factor b/basis/editors/emacs/emacs.factor index 366bc53104..31fcaf114e 100644 --- a/basis/editors/emacs/emacs.factor +++ b/basis/editors/emacs/emacs.factor @@ -11,7 +11,10 @@ M: object default-emacsclient ( -- path ) "emacsclient" ; : emacsclient ( file line -- ) [ - { [ emacsclient-path get ] [ default-emacsclient ] } 0|| , + { + [ emacsclient-path get-global ] + [ default-emacsclient dup emacsclient-path set-global ] + } 0|| , "--no-wait" , number>string "+" prepend , , diff --git a/basis/editors/emacs/windows/windows.factor b/basis/editors/emacs/windows/windows.factor index 91d6e878e4..0b8efcf3ae 100755 --- a/basis/editors/emacs/windows/windows.factor +++ b/basis/editors/emacs/windows/windows.factor @@ -8,5 +8,5 @@ M: windows default-emacsclient { [ "Emacs" [ "emacsclientw.exe" tail? ] find-in-program-files ] [ "Emacs" [ "emacsclient.exe" tail? ] find-in-program-files ] - [ "emacsclient.exe" ] + [ "emacs.exe" ] } 0|| ; From 3d895de0cc9468aa3d3bde14d549e1f1ddb09ae1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 19:11:47 -0500 Subject: [PATCH 58/98] oops, really search for emacs.exe --- basis/editors/emacs/windows/windows.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/editors/emacs/windows/windows.factor b/basis/editors/emacs/windows/windows.factor index 0b8efcf3ae..0fb6c8e68c 100755 --- a/basis/editors/emacs/windows/windows.factor +++ b/basis/editors/emacs/windows/windows.factor @@ -8,5 +8,6 @@ M: windows default-emacsclient { [ "Emacs" [ "emacsclientw.exe" tail? ] find-in-program-files ] [ "Emacs" [ "emacsclient.exe" tail? ] find-in-program-files ] + [ "Emacs" [ "emacs.exe" tail? ] find-in-program-files ] [ "emacs.exe" ] } 0|| ; From be2639c1680f04416d8be3e0405b5afaa834c169 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 19:52:50 -0500 Subject: [PATCH 59/98] look for emacsclient.exe not emacs.exe --- basis/editors/emacs/windows/windows.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/editors/emacs/windows/windows.factor b/basis/editors/emacs/windows/windows.factor index 0fb6c8e68c..91d6e878e4 100755 --- a/basis/editors/emacs/windows/windows.factor +++ b/basis/editors/emacs/windows/windows.factor @@ -8,6 +8,5 @@ M: windows default-emacsclient { [ "Emacs" [ "emacsclientw.exe" tail? ] find-in-program-files ] [ "Emacs" [ "emacsclient.exe" tail? ] find-in-program-files ] - [ "Emacs" [ "emacs.exe" tail? ] find-in-program-files ] - [ "emacs.exe" ] + [ "emacsclient.exe" ] } 0|| ; From 0d0c7f2d552770b3570dbd99025093f9fac3a669 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 20:05:17 -0500 Subject: [PATCH 60/98] Fix unit test failures caused by stricter type checking in M: encoder stream-write --- basis/io/encodings/8-bit/8-bit-tests.factor | 6 ++-- basis/io/encodings/ascii/ascii-tests.factor | 4 +-- .../io/encodings/gb18030/gb18030-tests.factor | 6 ++-- basis/io/encodings/utf16/utf16-tests.factor | 28 ++++++++-------- basis/io/encodings/utf32/utf32-tests.factor | 32 +++++++++---------- .../byte-array/byte-array-tests.factor | 4 +-- basis/io/streams/string/string.factor | 5 +-- basis/smtp/smtp.factor | 19 +++++------ basis/tools/profiler/profiler-docs.factor | 2 +- core/io/encodings/utf8/utf8-tests.factor | 2 +- 10 files changed, 55 insertions(+), 53 deletions(-) diff --git a/basis/io/encodings/8-bit/8-bit-tests.factor b/basis/io/encodings/8-bit/8-bit-tests.factor index 8b18e2a9af..55b9c44934 100644 --- a/basis/io/encodings/8-bit/8-bit-tests.factor +++ b/basis/io/encodings/8-bit/8-bit-tests.factor @@ -4,11 +4,11 @@ IN: io.encodings.8-bit.tests [ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test [ { 256 } >string latin1 encode ] must-fail -[ B{ 255 } ] [ { 255 } latin1 encode ] unit-test +[ B{ 255 } ] [ { 255 } >string latin1 encode ] unit-test [ "bar" ] [ "bar" latin1 decode ] unit-test -[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test -[ { HEX: fffd HEX: 20AC } ] [ { HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test +[ { CHAR: b 233 CHAR: r } ] [ B{ CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test +[ { HEX: fffd HEX: 20AC } ] [ B{ HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test [ t ] [ \ latin1 8-bit-encoding? ] unit-test [ "bar" ] [ "bar" \ latin1 decode ] unit-test diff --git a/basis/io/encodings/ascii/ascii-tests.factor b/basis/io/encodings/ascii/ascii-tests.factor index 4f6d28835a..fcd549d31f 100644 --- a/basis/io/encodings/ascii/ascii-tests.factor +++ b/basis/io/encodings/ascii/ascii-tests.factor @@ -3,7 +3,7 @@ IN: io.encodings.ascii.tests [ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" ascii encode ] unit-test [ { 128 } >string ascii encode ] must-fail -[ B{ 127 } ] [ { 127 } ascii encode ] unit-test +[ B{ 127 } ] [ { 127 } >string ascii encode ] unit-test [ "bar" ] [ "bar" ascii decode ] unit-test -[ { CHAR: b HEX: fffd CHAR: r } ] [ { CHAR: b 233 CHAR: r } ascii decode >array ] unit-test +[ { CHAR: b HEX: fffd CHAR: r } ] [ B{ CHAR: b 233 CHAR: r } ascii decode >array ] unit-test diff --git a/basis/io/encodings/gb18030/gb18030-tests.factor b/basis/io/encodings/gb18030/gb18030-tests.factor index 20ea522a4d..da44d1cf9a 100644 --- a/basis/io/encodings/gb18030/gb18030-tests.factor +++ b/basis/io/encodings/gb18030/gb18030-tests.factor @@ -6,7 +6,7 @@ IN: io.encodings.gb18030.tests [ "hello" ] [ "hello" gb18030 encode >string ] unit-test [ "hello" ] [ "hello" gb18030 decode ] unit-test [ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 HEX: 86 HEX: 30 } ] -[ B{ HEX: B7 HEX: B8 } gb18030 encode ] unit-test +[ B{ HEX: B7 HEX: B8 } >string gb18030 encode ] unit-test [ { HEX: B7 HEX: B8 } ] [ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 HEX: 86 HEX: 30 } gb18030 decode >array ] unit-test [ { HEX: B7 CHAR: replacement-character } ] @@ -18,9 +18,9 @@ IN: io.encodings.gb18030.tests [ { HEX: B7 } ] [ B{ HEX: A1 HEX: A4 } gb18030 decode >array ] unit-test [ { CHAR: replacement-character } ] -[ B{ HEX: A1 } gb18030 decode >array ] unit-test +[ B{ HEX: A1 } >string gb18030 decode >array ] unit-test [ { HEX: 44D7 HEX: 464B } ] [ B{ HEX: 82 HEX: 33 HEX: A3 HEX: 39 HEX: 82 HEX: 33 HEX: C9 HEX: 31 } gb18030 decode >array ] unit-test [ { HEX: 82 HEX: 33 HEX: A3 HEX: 39 HEX: 82 HEX: 33 HEX: C9 HEX: 31 } ] -[ { HEX: 44D7 HEX: 464B } gb18030 encode >array ] unit-test +[ { HEX: 44D7 HEX: 464B } >string gb18030 encode >array ] unit-test diff --git a/basis/io/encodings/utf16/utf16-tests.factor b/basis/io/encodings/utf16/utf16-tests.factor index 230612cc77..e16c1f822e 100644 --- a/basis/io/encodings/utf16/utf16-tests.factor +++ b/basis/io/encodings/utf16/utf16-tests.factor @@ -1,25 +1,25 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test io.encodings.utf16 arrays sbufs -io.streams.byte-array sequences io.encodings io +io.streams.byte-array sequences io.encodings io strings io.encodings.string alien.c-types alien.strings accessors classes ; IN: io.encodings.utf16.tests -[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test -[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test +[ { CHAR: x } ] [ B{ 0 CHAR: x } utf16be decode >array ] unit-test +[ { HEX: 1D11E } ] [ B{ HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test -[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode >array ] unit-test +[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } >string utf16be encode >array ] unit-test -[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode >array ] unit-test -[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test +[ { CHAR: x } ] [ B{ CHAR: x 0 } utf16le decode >array ] unit-test +[ { 119070 } ] [ B{ HEX: 34 HEX: D8 HEX: 1E HEX: DD } >string utf16le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } >string utf16le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } >string utf16le decode >array ] unit-test -[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test +[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16le encode >array ] unit-test -[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test -[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test +[ { CHAR: x } ] [ B{ HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test +[ { CHAR: x } ] [ B{ HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test -[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test +[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16 encode >array ] unit-test diff --git a/basis/io/encodings/utf32/utf32-tests.factor b/basis/io/encodings/utf32/utf32-tests.factor index be1111e242..2a80e47c7b 100644 --- a/basis/io/encodings/utf32/utf32-tests.factor +++ b/basis/io/encodings/utf32/utf32-tests.factor @@ -1,30 +1,30 @@ ! Copyright (C) 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test io.encodings.utf32 arrays sbufs -io.streams.byte-array sequences io.encodings io +io.streams.byte-array sequences io.encodings io strings io.encodings.string alien.c-types alien.strings accessors classes ; IN: io.encodings.utf32.tests -[ { CHAR: x } ] [ { 0 0 0 CHAR: x } utf32be decode >array ] unit-test -[ { HEX: 1D11E } ] [ { 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 1 HEX: D1 } utf32be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 1 } utf32be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 } utf32be decode >array ] unit-test +[ { CHAR: x } ] [ B{ 0 0 0 CHAR: x } utf32be decode >array ] unit-test +[ { HEX: 1D11E } ] [ B{ 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ 0 1 HEX: D1 } utf32be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ 0 1 } utf32be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ 0 } utf32be decode >array ] unit-test [ { } ] [ { } utf32be decode >array ] unit-test -[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } utf32be encode >array ] unit-test +[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } >string utf32be encode >array ] unit-test -[ { CHAR: x } ] [ { CHAR: x 0 0 0 } utf32le decode >array ] unit-test -[ { HEX: 1d11e } ] [ { HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 } utf32le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { HEX: 1e } utf32le decode >array ] unit-test +[ { CHAR: x } ] [ B{ CHAR: x 0 0 0 } utf32le decode >array ] unit-test +[ { HEX: 1d11e } ] [ B{ HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ HEX: 1e HEX: d1 } utf32le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ HEX: 1e } utf32le decode >array ] unit-test [ { } ] [ { } utf32le decode >array ] unit-test -[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32le encode >array ] unit-test +[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32le encode >array ] unit-test -[ { CHAR: x } ] [ { HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test -[ { CHAR: x } ] [ { 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test +[ { CHAR: x } ] [ B{ HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test +[ { CHAR: x } ] [ B{ 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test -[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32 encode >array ] unit-test +[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32 encode >array ] unit-test diff --git a/basis/io/streams/byte-array/byte-array-tests.factor b/basis/io/streams/byte-array/byte-array-tests.factor index 44290bfb47..3cf52c6a78 100644 --- a/basis/io/streams/byte-array/byte-array-tests.factor +++ b/basis/io/streams/byte-array/byte-array-tests.factor @@ -1,11 +1,11 @@ USING: tools.test io.streams.byte-array io.encodings.binary io.encodings.utf8 io kernel arrays strings namespaces ; -[ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test +[ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test [ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test [ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ] -[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test +[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test [ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 contents dup >array swap string? ] unit-test [ B{ 121 120 } 0 ] [ diff --git a/basis/io/streams/string/string.factor b/basis/io/streams/string/string.factor index a0087a70ee..85cb3022f5 100644 --- a/basis/io/streams/string/string.factor +++ b/basis/io/streams/string/string.factor @@ -33,5 +33,6 @@ M: sbuf stream-element-type drop +character+ ; 512 ; : with-string-writer ( quot -- str ) - swap [ output-stream get ] compose with-output-stream* - >string ; inline \ No newline at end of file + [ + swap with-output-stream* + ] keep >string ; inline \ No newline at end of file diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index bfba9ea28a..83457defa5 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -1,12 +1,12 @@ -! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, +! Copyright (C) 2007, 2009 Elie CHAFTARI, Dirk Vleugels, ! Slava Pestov, Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays namespaces make io io.encodings.string io.encodings.utf8 -io.encodings.iana io.timeouts io.sockets io.sockets.secure -io.encodings.ascii kernel logging sequences combinators splitting -assocs strings math.order math.parser random system calendar summary -calendar.format accessors sets hashtables base64 debugger classes -prettyprint io.crlf words ; +USING: arrays namespaces make io io.encodings io.encodings.string +io.encodings.utf8 io.encodings.iana io.encodings.binary +io.encodings.ascii io.timeouts io.sockets io.sockets.secure io.crlf +kernel logging sequences combinators splitting assocs strings +math.order math.parser random system calendar summary calendar.format +accessors sets hashtables base64 debugger classes prettyprint words ; IN: smtp SYMBOL: smtp-domain @@ -88,8 +88,9 @@ M: message-contains-dot summary ( obj -- string ) [ message-contains-dot ] when ; : send-body ( email -- ) - [ body>> ] [ encoding>> ] bi encode - >base64-lines write crlf + binary encode-output + [ body>> ] [ encoding>> ] bi encode >base64-lines write + ascii encode-output crlf "." command ; : quit ( -- ) diff --git a/basis/tools/profiler/profiler-docs.factor b/basis/tools/profiler/profiler-docs.factor index a786cdfef1..baecbd71c1 100644 --- a/basis/tools/profiler/profiler-docs.factor +++ b/basis/tools/profiler/profiler-docs.factor @@ -23,7 +23,7 @@ $nl { $subsection vocabs-profile. } { $subsection method-profile. } { $subsection "profiler-limitations" } -{ $see-also "ui-profiler" } ; +{ $see-also "ui.tools.profiler" } ; ABOUT: "profiling" diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor index 6cd3ee8033..088131acf9 100755 --- a/core/io/encodings/utf8/utf8-tests.factor +++ b/core/io/encodings/utf8/utf8-tests.factor @@ -6,7 +6,7 @@ IN: io.encodings.utf8.tests utf8 decode >array ; : encode-utf8-w/stream ( array -- newarray ) - utf8 encode >array ; + >string utf8 encode >array ; [ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream ] unit-test From 08d80f623742d396a9626d2242470c9d43ccf1d0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 21:11:50 -0500 Subject: [PATCH 61/98] use HOMEDRIVE/HOMEPATH for HOME, then USERPROFILE, the default to a directory if no env vars are set --- basis/io/files/windows/nt/nt.factor | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/basis/io/files/windows/nt/nt.factor b/basis/io/files/windows/nt/nt.factor index 9e449982fb..afc81c784c 100755 --- a/basis/io/files/windows/nt/nt.factor +++ b/basis/io/files/windows/nt/nt.factor @@ -4,7 +4,7 @@ io.backend.windows io.files.windows io.encodings.utf16n windows windows.kernel32 kernel libc math threads system environment alien.c-types alien.arrays alien.strings sequences combinators combinators.short-circuit ascii splitting alien strings assocs -namespaces make accessors tr windows.time ; +namespaces make accessors tr windows.time windows.shell32 ; IN: io.files.windows.nt M: winnt cwd @@ -58,4 +58,9 @@ M: winnt open-append [ dup windows-file-size ] [ drop 0 ] recover [ (open-append) ] dip >>ptr ; -M: winnt home "USERPROFILE" os-env ; +M: winnt home + { + [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ] + [ "USERPROFILE" os-env ] + [ my-documents ] + } 0|| ; From 05f3f9dcb90b2228c56a3999c8a3fd1f8f544bd7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 21:15:19 -0500 Subject: [PATCH 62/98] Fixing unit tests for stack effect inference changes --- basis/alarms/alarms-tests.factor | 2 - basis/alien/c-types/c-types-tests.factor | 2 - basis/base64/base64-tests.factor | 3 - .../binary-search/binary-search-tests.factor | 2 - basis/bootstrap/image/image-tests.factor | 3 - basis/calendar/calendar-tests.factor | 4 - .../format/macros/macros-tests.factor | 2 +- basis/combinators/smart/smart-tests.factor | 2 +- .../compiler/cfg/builder/builder-tests.factor | 2 - .../assignment/assignment-tests.factor | 2 +- .../linearization/linearization-tests.factor | 2 +- basis/compiler/tests/insane.factor | 5 - basis/compiler/tests/optimizer.factor | 6 +- basis/compiler/tests/redefine1.factor | 38 --- basis/compiler/tests/redefine16.factor | 3 +- basis/compiler/tests/simple.factor | 2 - .../tree/builder/builder-tests.factor | 26 +- .../tree/checker/checker-tests.factor | 2 +- .../tree/dead-code/dead-code-tests.factor | 2 - .../tree/debugger/debugger-tests.factor | 3 - .../tree/def-use/def-use-tests.factor | 2 - .../escape-analysis-tests.factor | 2 - .../normalization/normalization-tests.factor | 3 - .../tree/optimizer/optimizer-tests.factor | 2 +- .../tree/propagation/propagation-tests.factor | 2 - .../tree/recursive/recursive-tests.factor | 6 - .../tuple-unboxing-tests.factor | 2 - basis/db/pools/pools-tests.factor | 2 - basis/db/tuples/tuples-tests.factor | 11 - basis/functors/functors-tests.factor | 2 - basis/furnace/auth/auth-tests.factor | 3 - .../edit-profile/edit-profile-tests.factor | 2 +- .../recover-password-tests.factor | 2 +- .../registration/registration-tests.factor | 2 +- basis/furnace/auth/login/login-tests.factor | 2 +- basis/furnace/db/db-tests.factor | 2 +- basis/help/markup/markup-tests.factor | 2 - basis/help/topics/topics-tests.factor | 5 - basis/html/components/components-tests.factor | 2 - basis/http/client/client-tests.factor | 2 - .../dispatchers/dispatchers-tests.factor | 2 - .../redirection/redirection-tests.factor | 2 - basis/http/server/server-tests.factor | 2 - basis/io/files/info/info-tests.factor | 3 - basis/io/launcher/launcher-tests.factor | 3 - .../monitors/recursive/recursive-tests.factor | 2 - basis/io/monitors/windows/nt/nt-tests.factor | 2 +- .../io/sockets/secure/unix/unix-tests.factor | 1 - basis/io/styles/styles-tests.factor | 6 - basis/lcs/lcs-tests.factor | 4 - basis/locals/backend/backend-tests.factor | 6 +- basis/locals/locals-tests.factor | 45 ++-- basis/math/bitwise/bitwise-tests.factor | 2 +- basis/models/models-tests.factor | 3 - basis/peg/peg-tests.factor | 2 - basis/peg/search/search-tests.factor | 2 - basis/persistent/vectors/vectors-tests.factor | 4 - basis/regexp/regexp-tests.factor | 4 - basis/smtp/smtp-tests.factor | 2 - .../stack-checker/stack-checker-tests.factor | 234 +----------------- .../transforms/transforms-tests.factor | 5 + basis/syndication/syndication-tests.factor | 3 - basis/tools/memory/memory-tests.factor | 3 - basis/tools/test/test-docs.factor | 4 +- basis/tools/test/test-tests.factor | 2 - basis/tools/test/test.factor | 3 +- basis/ui/event-loop/event-loop-tests.factor | 2 - basis/ui/gadgets/books/books-tests.factor | 2 - basis/ui/gadgets/buttons/buttons-tests.factor | 4 - basis/ui/gadgets/editors/editors-tests.factor | 2 - basis/ui/gadgets/gadgets-tests.factor | 13 - .../gadgets/scrollers/scrollers-tests.factor | 2 - basis/ui/gestures/gestures-tests.factor | 3 - basis/ui/operations/operations-tests.factor | 2 - basis/ui/render/render-tests.factor | 2 - basis/ui/tools/browser/browser-tests.factor | 1 - .../ui/tools/inspector/inspector-tests.factor | 2 - basis/ui/tools/listener/listener-tests.factor | 2 - basis/ui/tools/profiler/profiler-tests.factor | 2 +- basis/ui/tools/walker/walker-tests.factor | 1 - basis/ui/ui-tests.factor | 3 - basis/unicode/case/case-tests.factor | 4 - basis/unix/groups/groups-tests.factor | 2 - basis/unix/users/users-tests.factor | 3 - basis/wrap/strings/strings-tests.factor | 2 - basis/wrap/words/words-tests.factor | 1 - basis/xml/syntax/syntax-tests.factor | 3 - basis/xml/tests/test.factor | 2 - basis/xml/writer/writer-tests.factor | 3 - basis/xmode/code2html/code2html-tests.factor | 2 - core/checksums/checksums-tests.factor | 4 - core/classes/algebra/algebra-tests.factor | 6 - core/classes/tuple/tuple-tests.factor | 2 +- core/combinators/combinators-tests.factor | 22 +- core/continuations/continuations-tests.factor | 2 +- core/io/files/files-tests.factor | 3 - core/parser/parser-tests.factor | 2 - extra/contributors/contributors-tests.factor | 1 - extra/infix/parser/parser-tests.factor | 3 - extra/infix/tokenizer/tokenizer-tests.factor | 1 - extra/mason/cleanup/cleanup-tests.factor | 2 - .../mason/release/upload/upload-tests.factor | 1 - extra/multi-methods/tests/definitions.factor | 3 - extra/peg/javascript/javascript-tests.factor | 2 - .../peg/javascript/parser/parser-tests.factor | 2 - .../tokenizer/tokenizer-tests.factor | 2 - 106 files changed, 92 insertions(+), 553 deletions(-) delete mode 100644 basis/compiler/tests/insane.factor diff --git a/basis/alarms/alarms-tests.factor b/basis/alarms/alarms-tests.factor index d1161e4cee..7c64680a83 100644 --- a/basis/alarms/alarms-tests.factor +++ b/basis/alarms/alarms-tests.factor @@ -15,5 +15,3 @@ tools.test threads concurrency.count-downs ; [ resume ] curry instant later drop ] "test" suspend drop ] unit-test - -\ alarm-thread-loop must-infer diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index 988dc180e0..ea9e881fd4 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -2,8 +2,6 @@ IN: alien.c-types.tests USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc alien.strings io.encodings.utf8 ; -\ expand-constants must-infer - CONSTANT: xyz 123 [ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test diff --git a/basis/base64/base64-tests.factor b/basis/base64/base64-tests.factor index 572d8a5227..9094286575 100644 --- a/basis/base64/base64-tests.factor +++ b/basis/base64/base64-tests.factor @@ -25,6 +25,3 @@ IN: base64.tests [ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ] [ malformed-base64? ] must-fail-with - -\ >base64 must-infer -\ base64> must-infer diff --git a/basis/binary-search/binary-search-tests.factor b/basis/binary-search/binary-search-tests.factor index 77b1c16505..63d2697418 100644 --- a/basis/binary-search/binary-search-tests.factor +++ b/basis/binary-search/binary-search-tests.factor @@ -1,8 +1,6 @@ IN: binary-search.tests USING: binary-search math.order vectors kernel tools.test ; -\ sorted-member? must-infer - [ f ] [ 3 { } [ <=> ] with search drop ] unit-test [ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test [ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test diff --git a/basis/bootstrap/image/image-tests.factor b/basis/bootstrap/image/image-tests.factor index c432a47ea4..e7070d3cf2 100644 --- a/basis/bootstrap/image/image-tests.factor +++ b/basis/bootstrap/image/image-tests.factor @@ -2,9 +2,6 @@ IN: bootstrap.image.tests USING: bootstrap.image bootstrap.image.private tools.test kernel math ; -\ ' must-infer -\ write-image must-infer - [ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test [ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor index b6d8e74072..256b4e1b42 100644 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -2,10 +2,6 @@ USING: arrays calendar kernel math sequences tools.test continuations system math.order threads ; IN: calendar.tests -\ time+ must-infer -\ time* must-infer -\ time- must-infer - [ f ] [ 2004 12 32 0 0 0 instant valid-timestamp? ] unit-test [ f ] [ 2004 2 30 0 0 0 instant valid-timestamp? ] unit-test [ f ] [ 2003 2 29 0 0 0 instant valid-timestamp? ] unit-test diff --git a/basis/calendar/format/macros/macros-tests.factor b/basis/calendar/format/macros/macros-tests.factor index 544332770f..48567539ad 100644 --- a/basis/calendar/format/macros/macros-tests.factor +++ b/basis/calendar/format/macros/macros-tests.factor @@ -10,6 +10,6 @@ IN: calendar.format.macros : compiled-test-1 ( -- n ) { [ 1 throw ] [ 2 ] } attempt-all-quots ; -\ compiled-test-1 must-infer +\ compiled-test-1 def>> must-infer [ 2 ] [ compiled-test-1 ] unit-test diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 1cca697dde..080379e924 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -42,7 +42,7 @@ IN: combinators.smart.tests : nested-smart-combo-test ( -- array ) [ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ; -\ nested-smart-combo-test must-infer +\ nested-smart-combo-test def>> must-infer [ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 0b303a8a43..58eae8181b 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -5,8 +5,6 @@ math.private compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays kernel.private math ; -\ build-cfg must-infer - ! Just ensure that various CFGs build correctly. : unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor index 9efc23651b..13c1783711 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor @@ -1,4 +1,4 @@ USING: compiler.cfg.linear-scan.assignment tools.test ; IN: compiler.cfg.linear-scan.assignment.tests -\ assign-registers must-infer + diff --git a/basis/compiler/cfg/linearization/linearization-tests.factor b/basis/compiler/cfg/linearization/linearization-tests.factor index 5e866d15db..fe8b4fd0c0 100644 --- a/basis/compiler/cfg/linearization/linearization-tests.factor +++ b/basis/compiler/cfg/linearization/linearization-tests.factor @@ -1,4 +1,4 @@ IN: compiler.cfg.linearization.tests USING: compiler.cfg.linearization tools.test ; -\ build-mr must-infer + diff --git a/basis/compiler/tests/insane.factor b/basis/compiler/tests/insane.factor deleted file mode 100644 index aa79067252..0000000000 --- a/basis/compiler/tests/insane.factor +++ /dev/null @@ -1,5 +0,0 @@ -IN: compiler.tests -USING: words kernel stack-checker alien.strings tools.test -compiler.units ; - -[ ] [ [ \ if redefined ] with-compilation-unit [ string>alien ] infer. ] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 3aed47ae7e..23b69b06b9 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -261,7 +261,7 @@ USE: binary-search.private : lift-loop-tail-test-2 ( -- a b c ) 10 [ ] lift-loop-tail-test-1 1 2 3 ; -\ lift-loop-tail-test-2 must-infer +\ lift-loop-tail-test-2 def>> must-infer [ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test @@ -302,7 +302,7 @@ HINTS: recursive-inline-hang-3 array ; : member-test ( obj -- ? ) { + - * / /i } member? ; -\ member-test must-infer +\ member-test def>> must-infer [ ] [ \ member-test build-tree-from-word optimize-tree drop ] unit-test [ t ] [ \ + member-test ] unit-test [ f ] [ \ append member-test ] unit-test @@ -325,7 +325,7 @@ PREDICATE: list < improper-list dup "a" get { array-capacity } declare >= [ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ; -\ interval-inference-bug must-infer +[ t ] [ \ interval-inference-bug optimized>> ] unit-test [ ] [ 1 "a" set 2 "b" set ] unit-test [ 2 3 ] [ 2 interval-inference-bug ] unit-test diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor index 8145ad628b..a28b183fb6 100644 --- a/basis/compiler/tests/redefine1.factor +++ b/basis/compiler/tests/redefine1.factor @@ -36,41 +36,3 @@ M: integer method-redefine-generic-2 3 + ; fixnum string [ \ method-redefine-generic-2 method forget ] bi@ ] with-compilation-unit ] unit-test - -! Test ripple-up behavior -: hey ( -- ) ; -: there ( -- ) hey ; - -[ t ] [ \ hey optimized>> ] unit-test -[ t ] [ \ there optimized>> ] unit-test -[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval( -- ) ] unit-test -[ f ] [ \ hey optimized>> ] unit-test -[ f ] [ \ there optimized>> ] unit-test -[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval( -- ) ] unit-test -[ t ] [ \ there optimized>> ] unit-test - -: good ( -- ) ; -: bad ( -- ) good ; -: ugly ( -- ) bad ; - -[ t ] [ \ good optimized>> ] unit-test -[ t ] [ \ bad optimized>> ] unit-test -[ t ] [ \ ugly optimized>> ] unit-test - -[ f ] [ \ good compiled-usage assoc-empty? ] unit-test - -[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval( -- ) ] unit-test - -[ f ] [ \ good optimized>> ] unit-test -[ f ] [ \ bad optimized>> ] unit-test -[ f ] [ \ ugly optimized>> ] unit-test - -[ t ] [ \ good compiled-usage assoc-empty? ] unit-test - -[ ] [ "IN: compiler.tests : good ( -- ) ;" eval( -- ) ] unit-test - -[ t ] [ \ good optimized>> ] unit-test -[ t ] [ \ bad optimized>> ] unit-test -[ t ] [ \ ugly optimized>> ] unit-test - -[ f ] [ \ good compiled-usage assoc-empty? ] unit-test diff --git a/basis/compiler/tests/redefine16.factor b/basis/compiler/tests/redefine16.factor index e0bb1773c9..264b9b0675 100644 --- a/basis/compiler/tests/redefine16.factor +++ b/basis/compiler/tests/redefine16.factor @@ -6,5 +6,4 @@ quotations stack-checker ; [ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test [ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test -[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test -[ "blah" "compiler.tests.redefine16" lookup 1quotation infer ] must-fail +[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index 769182a8b1..11b27979d5 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -3,8 +3,6 @@ sequences.private math.private math combinators strings alien arrays memory vocabs parser eval ; IN: compiler.tests -\ (compile) must-infer - ! Test empty word [ ] [ [ ] compile-call ] unit-test diff --git a/basis/compiler/tree/builder/builder-tests.factor b/basis/compiler/tree/builder/builder-tests.factor index 4982a3986c..9668272957 100755 --- a/basis/compiler/tree/builder/builder-tests.factor +++ b/basis/compiler/tree/builder/builder-tests.factor @@ -1,11 +1,27 @@ IN: compiler.tree.builder.tests USING: compiler.tree.builder tools.test sequences kernel -compiler.tree ; - -\ build-tree must-infer -\ build-tree-with must-infer -\ build-tree-from-word must-infer +compiler.tree stack-checker stack-checker.errors ; : inline-recursive ( -- ) inline-recursive ; inline recursive [ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? ] unit-test + +: bad-recursion-1 ( a -- b ) + dup [ drop bad-recursion-1 5 ] [ ] if ; + +[ \ bad-recursion-1 build-tree-from-word ] [ inference-error? ] must-fail-with + +FORGET: bad-recursion-1 + +: bad-recursion-2 ( obj -- obj ) + dup [ dup first swap second bad-recursion-2 ] [ ] if ; + +[ \ bad-recursion-2 build-tree-from-word ] [ inference-error? ] must-fail-with + +FORGET: bad-recursion-2 + +: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; + +[ \ bad-bin build-tree-from-word ] [ inference-error? ] must-fail-with + +FORGET: bad-bin diff --git a/basis/compiler/tree/checker/checker-tests.factor b/basis/compiler/tree/checker/checker-tests.factor index 5a8706b900..d9591e7be2 100644 --- a/basis/compiler/tree/checker/checker-tests.factor +++ b/basis/compiler/tree/checker/checker-tests.factor @@ -1,4 +1,4 @@ IN: compiler.tree.checker.tests USING: compiler.tree.checker tools.test ; -\ check-nodes must-infer + diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor index 7c28866e94..ed4df91eec 100644 --- a/basis/compiler/tree/dead-code/dead-code-tests.factor +++ b/basis/compiler/tree/dead-code/dead-code-tests.factor @@ -9,8 +9,6 @@ accessors combinators io prettyprint words sequences.deep sequences.private arrays classes kernel.private ; IN: compiler.tree.dead-code.tests -\ remove-dead-code must-infer - : count-live-values ( quot -- n ) build-tree analyze-recursive diff --git a/basis/compiler/tree/debugger/debugger-tests.factor b/basis/compiler/tree/debugger/debugger-tests.factor index 9b4a6da12a..9bacd51be1 100644 --- a/basis/compiler/tree/debugger/debugger-tests.factor +++ b/basis/compiler/tree/debugger/debugger-tests.factor @@ -1,8 +1,5 @@ IN: compiler.tree.debugger.tests USING: compiler.tree.debugger tools.test sorting sequences io math.order ; -\ optimized. must-infer -\ optimizer-report. must-infer - [ [ <=> ] sort ] optimized. [ [ print ] each ] optimizer-report. \ No newline at end of file diff --git a/basis/compiler/tree/def-use/def-use-tests.factor b/basis/compiler/tree/def-use/def-use-tests.factor index d970e04afd..227a1f1dd7 100644 --- a/basis/compiler/tree/def-use/def-use-tests.factor +++ b/basis/compiler/tree/def-use/def-use-tests.factor @@ -7,8 +7,6 @@ compiler.tree.def-use arrays kernel.private sorting math.order binary-search compiler.tree.checker ; IN: compiler.tree.def-use.tests -\ compute-def-use must-infer - [ t ] [ [ 1 2 3 ] build-tree compute-def-use drop def-use get { diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index 9a226b954f..bcb8b2f80a 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -11,8 +11,6 @@ compiler.tree.propagation.info stack-checker.errors compiler.tree.checker kernel.private ; -\ escape-analysis must-infer - GENERIC: count-unboxed-allocations* ( m node -- n ) : (count-unboxed-allocations) ( m node -- n ) diff --git a/basis/compiler/tree/normalization/normalization-tests.factor b/basis/compiler/tree/normalization/normalization-tests.factor index 680ae0b170..3b4574effe 100644 --- a/basis/compiler/tree/normalization/normalization-tests.factor +++ b/basis/compiler/tree/normalization/normalization-tests.factor @@ -6,9 +6,6 @@ compiler.tree.normalization.renaming compiler.tree compiler.tree.checker sequences accessors tools.test kernel math ; -\ count-introductions must-infer -\ normalize must-infer - [ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test [ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree count-introductions ] unit-test diff --git a/basis/compiler/tree/optimizer/optimizer-tests.factor b/basis/compiler/tree/optimizer/optimizer-tests.factor index 1075e441e7..5d05947b8a 100644 --- a/basis/compiler/tree/optimizer/optimizer-tests.factor +++ b/basis/compiler/tree/optimizer/optimizer-tests.factor @@ -1,4 +1,4 @@ USING: compiler.tree.optimizer tools.test ; IN: compiler.tree.optimizer.tests -\ optimize-tree must-infer + diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 5b9b49811f..f6308ac40a 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -12,8 +12,6 @@ specialized-arrays.double system sorting math.libm math.intervals ; IN: compiler.tree.propagation.tests -\ propagate must-infer - [ V{ } ] [ [ ] final-classes ] unit-test [ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test diff --git a/basis/compiler/tree/recursive/recursive-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor index 971675d367..80edae076f 100644 --- a/basis/compiler/tree/recursive/recursive-tests.factor +++ b/basis/compiler/tree/recursive/recursive-tests.factor @@ -10,8 +10,6 @@ compiler.tree.combinators ; [ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test [ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test -\ analyze-recursive must-infer - : label-is-loop? ( nodes word -- ? ) [ { @@ -21,8 +19,6 @@ compiler.tree.combinators ; } 2&& ] curry contains-node? ; -\ label-is-loop? must-infer - : label-is-not-loop? ( nodes word -- ? ) [ { @@ -32,8 +28,6 @@ compiler.tree.combinators ; } 2&& ] curry contains-node? ; -\ label-is-not-loop? must-infer - : loop-test-1 ( a -- ) dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index 81ba01f1e2..8654a6f983 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -8,8 +8,6 @@ compiler.tree.def-use kernel accessors sequences math math.private sorting math.order binary-search sequences.private slots.private ; -\ unbox-tuples must-infer - : test-unboxing ( quot -- ) build-tree analyze-recursive diff --git a/basis/db/pools/pools-tests.factor b/basis/db/pools/pools-tests.factor index 7ff2a33d92..334ff9e11a 100644 --- a/basis/db/pools/pools-tests.factor +++ b/basis/db/pools/pools-tests.factor @@ -2,8 +2,6 @@ IN: db.pools.tests USING: db.pools tools.test continuations io.files io.files.temp io.directories namespaces accessors kernel math destructors ; -\ must-infer - { 1 0 } [ [ ] with-db-pool ] must-infer-as { 1 0 } [ [ ] with-pooled-db ] must-infer-as diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 375ee509bb..afdee3e89f 100644 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -592,17 +592,6 @@ string-encoding-test "STRING_ENCODING_TEST" { [ test-string-encoding ] test-sqlite [ test-string-encoding ] test-postgresql -! Don't comment these out. These words must infer -\ bind-tuple must-infer -\ insert-tuple must-infer -\ update-tuple must-infer -\ delete-tuples must-infer -\ select-tuple must-infer -\ define-persistent must-infer -\ ensure-table must-infer -\ create-table must-infer -\ drop-table must-infer - : test-queries ( -- ) [ ] [ exam ensure-table ] unit-test [ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index b4417532b4..37ec1d3e15 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -43,8 +43,6 @@ WHERE >> -\ sqsq must-infer - [ 16 ] [ 2 sqsq ] unit-test << diff --git a/basis/furnace/auth/auth-tests.factor b/basis/furnace/auth/auth-tests.factor index 220a8cd04c..54c32e7b4a 100644 --- a/basis/furnace/auth/auth-tests.factor +++ b/basis/furnace/auth/auth-tests.factor @@ -1,6 +1,3 @@ USING: furnace.auth tools.test ; IN: furnace.auth.tests -\ logged-in-username must-infer -\ must-infer -\ new-realm must-infer diff --git a/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor b/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor index d0fdf22c27..996047e83d 100644 --- a/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor +++ b/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor @@ -1,4 +1,4 @@ IN: furnace.auth.features.edit-profile.tests USING: tools.test furnace.auth.features.edit-profile ; -\ allow-edit-profile must-infer + diff --git a/basis/furnace/auth/features/recover-password/recover-password-tests.factor b/basis/furnace/auth/features/recover-password/recover-password-tests.factor index b589c52624..313b8ef397 100644 --- a/basis/furnace/auth/features/recover-password/recover-password-tests.factor +++ b/basis/furnace/auth/features/recover-password/recover-password-tests.factor @@ -1,4 +1,4 @@ IN: furnace.auth.features.recover-password USING: tools.test furnace.auth.features.recover-password ; -\ allow-password-recovery must-infer + diff --git a/basis/furnace/auth/features/registration/registration-tests.factor b/basis/furnace/auth/features/registration/registration-tests.factor index e770f35586..42acda416c 100644 --- a/basis/furnace/auth/features/registration/registration-tests.factor +++ b/basis/furnace/auth/features/registration/registration-tests.factor @@ -1,4 +1,4 @@ IN: furnace.auth.features.registration.tests USING: tools.test furnace.auth.features.registration ; -\ allow-registration must-infer + diff --git a/basis/furnace/auth/login/login-tests.factor b/basis/furnace/auth/login/login-tests.factor index 64f7bd3b96..aabd0c5c30 100644 --- a/basis/furnace/auth/login/login-tests.factor +++ b/basis/furnace/auth/login/login-tests.factor @@ -1,4 +1,4 @@ IN: furnace.auth.login.tests USING: tools.test furnace.auth.login ; -\ must-infer + diff --git a/basis/furnace/db/db-tests.factor b/basis/furnace/db/db-tests.factor index 34357ae701..15698d8e9b 100644 --- a/basis/furnace/db/db-tests.factor +++ b/basis/furnace/db/db-tests.factor @@ -1,4 +1,4 @@ IN: furnace.db.tests USING: tools.test furnace.db ; -\ must-infer + diff --git a/basis/help/markup/markup-tests.factor b/basis/help/markup/markup-tests.factor index 9b928f3691..bcd8843b24 100644 --- a/basis/help/markup/markup-tests.factor +++ b/basis/help/markup/markup-tests.factor @@ -26,5 +26,3 @@ TUPLE: blahblah quux ; [ "a string, a fixnum, or an integer" ] [ [ { $or string fixnum integer } print-element ] with-string-writer ] unit-test -\ print-element must-infer -\ print-topic must-infer \ No newline at end of file diff --git a/basis/help/topics/topics-tests.factor b/basis/help/topics/topics-tests.factor index ac9223b5d2..cafeb009a4 100644 --- a/basis/help/topics/topics-tests.factor +++ b/basis/help/topics/topics-tests.factor @@ -3,11 +3,6 @@ help.markup help.syntax kernel sequences tools.test words parser namespaces assocs source-files eval ; IN: help.topics.tests -\ article-name must-infer -\ article-title must-infer -\ article-content must-infer -\ article-parent must-infer - ! Test help cross-referencing [ ] [ "Test B" { "Hello world." }
{ "test" "b" } add-article ] unit-test diff --git a/basis/html/components/components-tests.factor b/basis/html/components/components-tests.factor index 72ceea20a0..da2e5b5991 100644 --- a/basis/html/components/components-tests.factor +++ b/basis/html/components/components-tests.factor @@ -4,8 +4,6 @@ io.streams.null accessors inspector html.streams html.components html.forms namespaces xml.writer ; -\ render must-infer - [ ] [ begin-form ] unit-test [ ] [ 3 "hi" set-value ] unit-test diff --git a/basis/http/client/client-tests.factor b/basis/http/client/client-tests.factor index 4dcc6b8813..4f786cb22c 100644 --- a/basis/http/client/client-tests.factor +++ b/basis/http/client/client-tests.factor @@ -1,8 +1,6 @@ USING: http.client http.client.private http tools.test namespaces urls ; -\ download must-infer - [ "localhost" f ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test diff --git a/basis/http/server/dispatchers/dispatchers-tests.factor b/basis/http/server/dispatchers/dispatchers-tests.factor index 2c8db27259..08974aca3b 100644 --- a/basis/http/server/dispatchers/dispatchers-tests.factor +++ b/basis/http/server/dispatchers/dispatchers-tests.factor @@ -3,8 +3,6 @@ tools.test kernel namespaces accessors io http math sequences assocs arrays classes words urls ; IN: http.server.dispatchers.tests -\ find-responder must-infer - TUPLE: mock-responder path ; C: mock-responder diff --git a/basis/http/server/redirection/redirection-tests.factor b/basis/http/server/redirection/redirection-tests.factor index 14855ca875..72ff111db9 100644 --- a/basis/http/server/redirection/redirection-tests.factor +++ b/basis/http/server/redirection/redirection-tests.factor @@ -2,8 +2,6 @@ IN: http.server.redirection.tests USING: http http.server.redirection urls accessors namespaces tools.test present kernel ; -\ relative-to-request must-infer - [ diff --git a/basis/http/server/server-tests.factor b/basis/http/server/server-tests.factor index 171973fcd8..3dc97098a4 100644 --- a/basis/http/server/server-tests.factor +++ b/basis/http/server/server-tests.factor @@ -4,8 +4,6 @@ IN: http.server.tests [ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test -\ make-http-error must-infer - [ "text/plain; charset=UTF-8" ] [ "text/plain" >>content-type diff --git a/basis/io/files/info/info-tests.factor b/basis/io/files/info/info-tests.factor index b94bc0635c..7b19f56b10 100644 --- a/basis/io/files/info/info-tests.factor +++ b/basis/io/files/info/info-tests.factor @@ -3,9 +3,6 @@ io.directories kernel io.pathnames accessors tools.test sequences io.files.temp ; IN: io.files.info.tests -\ file-info must-infer -\ link-info must-infer - [ t ] [ temp-directory [ "hi41" "test41" utf8 set-file-contents ] with-directory temp-directory "test41" append-path utf8 file-contents "hi41" = diff --git a/basis/io/launcher/launcher-tests.factor b/basis/io/launcher/launcher-tests.factor index 003f382020..da7284dbe5 100644 --- a/basis/io/launcher/launcher-tests.factor +++ b/basis/io/launcher/launcher-tests.factor @@ -1,6 +1,3 @@ IN: io.launcher.tests USING: tools.test io.launcher ; -\ must-infer -\ must-infer -\ must-infer diff --git a/basis/io/monitors/recursive/recursive-tests.factor b/basis/io/monitors/recursive/recursive-tests.factor index ace93ace44..db8e02ae73 100644 --- a/basis/io/monitors/recursive/recursive-tests.factor +++ b/basis/io/monitors/recursive/recursive-tests.factor @@ -4,8 +4,6 @@ concurrency.mailboxes tools.test destructors io.files.info io.pathnames io.files.temp io.directories.hierarchy ; IN: io.monitors.recursive.tests -\ pump-thread must-infer - SINGLETON: mock-io-backend TUPLE: counter i ; diff --git a/basis/io/monitors/windows/nt/nt-tests.factor b/basis/io/monitors/windows/nt/nt-tests.factor index 79cd7e9e9f..a7ee649400 100644 --- a/basis/io/monitors/windows/nt/nt-tests.factor +++ b/basis/io/monitors/windows/nt/nt-tests.factor @@ -1,4 +1,4 @@ IN: io.monitors.windows.nt.tests USING: io.monitors.windows.nt tools.test ; -\ fill-queue-thread must-infer + diff --git a/basis/io/sockets/secure/unix/unix-tests.factor b/basis/io/sockets/secure/unix/unix-tests.factor index a3bfacc8a8..7c4dcc17d1 100644 --- a/basis/io/sockets/secure/unix/unix-tests.factor +++ b/basis/io/sockets/secure/unix/unix-tests.factor @@ -5,7 +5,6 @@ io.backend.unix classes words destructors threads tools.test concurrency.promises byte-arrays locals calendar io.timeouts io.sockets.secure.unix.debug ; -\ must-infer { 1 0 } [ [ ] with-secure-context ] must-infer-as [ ] [ "port" set ] unit-test diff --git a/basis/io/styles/styles-tests.factor b/basis/io/styles/styles-tests.factor index 86c3681c2a..0259e4ab0b 100644 --- a/basis/io/styles/styles-tests.factor +++ b/basis/io/styles/styles-tests.factor @@ -1,8 +1,2 @@ IN: io.styles.tests USING: io.styles tools.test ; - -\ stream-format must-infer -\ stream-write-table must-infer -\ make-span-stream must-infer -\ make-block-stream must-infer -\ make-cell-stream must-infer \ No newline at end of file diff --git a/basis/lcs/lcs-tests.factor b/basis/lcs/lcs-tests.factor index 7d9a9ffd27..3aa10a0687 100644 --- a/basis/lcs/lcs-tests.factor +++ b/basis/lcs/lcs-tests.factor @@ -2,10 +2,6 @@ ! See http://factorcode.org/license.txt for BSD license. USING: tools.test lcs ; -\ lcs must-infer -\ diff must-infer -\ levenshtein must-infer - [ 3 ] [ "sitting" "kitten" levenshtein ] unit-test [ 3 ] [ "kitten" "sitting" levenshtein ] unit-test [ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test diff --git a/basis/locals/backend/backend-tests.factor b/basis/locals/backend/backend-tests.factor index ee714f7ef7..ad78516059 100644 --- a/basis/locals/backend/backend-tests.factor +++ b/basis/locals/backend/backend-tests.factor @@ -1,14 +1,14 @@ IN: locals.backend.tests -USING: tools.test locals.backend kernel arrays ; +USING: tools.test locals.backend kernel arrays accessors ; : get-local-test-1 ( -- x ) 3 1 load-locals 0 get-local 1 drop-locals ; -\ get-local-test-1 must-infer +\ get-local-test-1 def>> must-infer [ 3 ] [ get-local-test-1 ] unit-test : get-local-test-2 ( -- x ) 3 4 2 load-locals -1 get-local 2 drop-locals ; -\ get-local-test-2 must-infer +\ get-local-test-2 def>> must-infer [ 3 ] [ get-local-test-2 ] unit-test diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index d472a8b22b..68fa8dbda0 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -43,8 +43,8 @@ IN: locals.tests [ { 1 2 } ] [ 2 let-test-4 ] unit-test -:: let-test-5 ( a -- b ) - a [let | a [ ] b [ ] | a b 2array ] ; +:: let-test-5 ( a b -- b ) + a b [let | a [ ] b [ ] | a b 2array ] ; [ { 2 1 } ] [ 1 2 let-test-5 ] unit-test @@ -129,7 +129,8 @@ write-test-2 "q" set SYMBOL: a :: use-test ( a b c -- a b c ) - USE: kernel ; + USE: kernel + a b c ; [ t ] [ a symbol? ] unit-test @@ -171,9 +172,9 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ; [ ] [ \ lambda-generic see ] unit-test -:: unparse-test-1 ( a -- ) [let | a! [ ] | ] ; +:: unparse-test-1 ( a -- ) [let | a! [ 3 ] | ] ; -[ "[let | a! [ ] | ]" ] [ +[ "[let | a! [ 3 ] | ]" ] [ \ unparse-test-1 "lambda" word-prop body>> first unparse ] unit-test @@ -286,7 +287,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; { [ a b > ] [ 5 ] } } cond ; -\ cond-test must-infer +\ cond-test def>> must-infer [ 3 ] [ 1 2 cond-test ] unit-test [ 4 ] [ 2 2 cond-test ] unit-test @@ -295,7 +296,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; :: 0&&-test ( a -- ? ) { [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ; -\ 0&&-test must-infer +\ 0&&-test def>> must-infer [ f ] [ 1.5 0&&-test ] unit-test [ f ] [ 3 0&&-test ] unit-test @@ -305,7 +306,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; :: &&-test ( a -- ? ) { [ a integer? ] [ a even? ] [ a 10 > ] } && ; -\ &&-test must-infer +\ &&-test def>> must-infer [ f ] [ 1.5 &&-test ] unit-test [ f ] [ 3 &&-test ] unit-test @@ -321,7 +322,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; ] ] ; -\ let-and-cond-test-1 must-infer +\ let-and-cond-test-1 def>> must-infer [ 20 ] [ let-and-cond-test-1 ] unit-test @@ -332,7 +333,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; ] ] ; -\ let-and-cond-test-2 must-infer +\ let-and-cond-test-2 def>> must-infer [ { 10 20 } ] [ let-and-cond-test-2 ] unit-test @@ -388,7 +389,7 @@ ERROR: punned-class x ; { 5 [ a a ^ ] } } case ; -\ big-case-test must-infer +\ big-case-test def>> must-infer [ 9 ] [ 3 big-case-test ] unit-test @@ -400,7 +401,7 @@ ERROR: punned-class x ; [| x | x 12 + { "howdy" } nth ] } case ; -\ littledan-case-problem-1 must-infer +\ littledan-case-problem-1 def>> must-infer [ "howdy" ] [ -12 \ littledan-case-problem-1 def>> call ] unit-test [ "howdy" ] [ -12 littledan-case-problem-1 ] unit-test @@ -412,7 +413,7 @@ ERROR: punned-class x ; [| x | x a - { "howdy" } nth ] } case ; -\ littledan-case-problem-2 must-infer +\ littledan-case-problem-2 def>> must-infer [ "howdy" ] [ -12 \ littledan-case-problem-2 def>> call ] unit-test [ "howdy" ] [ -12 littledan-case-problem-2 ] unit-test @@ -424,7 +425,7 @@ ERROR: punned-class x ; [| x | x a - { "howdy" } nth ] } cond ; -\ littledan-cond-problem-1 must-infer +\ littledan-cond-problem-1 def>> must-infer [ f ] [ -12 \ littledan-cond-problem-1 def>> call ] unit-test [ 4 ] [ 12 \ littledan-cond-problem-1 def>> call ] unit-test @@ -448,12 +449,12 @@ ERROR: punned-class x ; : littledan-case-problem-4 ( a -- b ) [ 1 + ] littledan-case-problem-3 ; -\ littledan-case-problem-4 must-infer +\ littledan-case-problem-4 def>> must-infer */ GENERIC: lambda-method-forget-test ( a -- b ) -M:: integer lambda-method-forget-test ( a -- b ) ; +M:: integer lambda-method-forget-test ( a -- b ) a ; [ ] [ [ M\ integer lambda-method-forget-test forget ] with-compilation-unit ] unit-test @@ -467,7 +468,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ; :: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline : funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ; -\ funny-macro-test must-infer +\ funny-macro-test def>> must-infer [ t ] [ 3 funny-macro-test ] unit-test [ f ] [ 2 funny-macro-test ] unit-test @@ -483,11 +484,11 @@ M:: integer lambda-method-forget-test ( a -- b ) ; :: FAILdog-1 ( -- b ) { [| c | c ] } ; -\ FAILdog-1 must-infer +\ FAILdog-1 def>> must-infer :: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ; -\ FAILdog-2 must-infer +\ FAILdog-2 def>> must-infer [ 3 ] [ 3 [| a | \ a ] call ] unit-test @@ -518,7 +519,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ; { [ is-integer? ] [ is-even? ] [ >10? ] } && ] ; -\ wlet-&&-test must-infer +\ wlet-&&-test def>> must-infer [ f ] [ 1.5 wlet-&&-test ] unit-test [ f ] [ 3 wlet-&&-test ] unit-test [ f ] [ 8 wlet-&&-test ] unit-test @@ -527,13 +528,13 @@ M:: integer lambda-method-forget-test ( a -- b ) ; : fry-locals-test-1 ( -- n ) [let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ; -\ fry-locals-test-1 must-infer +\ fry-locals-test-1 def>> must-infer [ 10 ] [ fry-locals-test-1 ] unit-test :: fry-locals-test-2 ( -- n ) [let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ; -\ fry-locals-test-2 must-infer +\ fry-locals-test-2 def>> must-infer [ 10 ] [ fry-locals-test-2 ] unit-test [ 1 ] [ 3 4 [| | '[ [ _ swap - ] call ] call ] call ] unit-test diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor index 7698760f84..e10853af18 100644 --- a/basis/math/bitwise/bitwise-tests.factor +++ b/basis/math/bitwise/bitwise-tests.factor @@ -26,7 +26,7 @@ CONSTANT: b 2 [ 3 ] [ foo ] unit-test [ 3 ] [ { a b } flags ] unit-test -\ foo must-infer +\ foo def>> must-infer [ 1 ] [ { 1 } flags ] unit-test diff --git a/basis/models/models-tests.factor b/basis/models/models-tests.factor index f875fa3140..7368a2aa54 100644 --- a/basis/models/models-tests.factor +++ b/basis/models/models-tests.factor @@ -31,6 +31,3 @@ T{ model-tester f f } "tester" set "tester" get "model-c" get value>> ] unit-test - -\ model-changed must-infer -\ set-model must-infer diff --git a/basis/peg/peg-tests.factor b/basis/peg/peg-tests.factor index 7d5cb1e76a..9a15dd2105 100644 --- a/basis/peg/peg-tests.factor +++ b/basis/peg/peg-tests.factor @@ -5,8 +5,6 @@ USING: kernel tools.test strings namespaces make arrays sequences peg peg.private peg.parsers accessors words math accessors ; IN: peg.tests -\ parse must-infer - [ ] [ reset-pegs ] unit-test [ diff --git a/basis/peg/search/search-tests.factor b/basis/peg/search/search-tests.factor index 96d89d4611..b22a5ef0d0 100644 --- a/basis/peg/search/search-tests.factor +++ b/basis/peg/search/search-tests.factor @@ -17,5 +17,3 @@ IN: peg.search.tests "abc 123 def 456" 'integer' [ 2 * number>string ] action replace ] unit-test -\ search must-infer -\ replace must-infer diff --git a/basis/persistent/vectors/vectors-tests.factor b/basis/persistent/vectors/vectors-tests.factor index c232db8533..95fa70558d 100644 --- a/basis/persistent/vectors/vectors-tests.factor +++ b/basis/persistent/vectors/vectors-tests.factor @@ -3,10 +3,6 @@ USING: accessors tools.test persistent.vectors persistent.sequences sequences kernel arrays random namespaces vectors math math.order ; -\ new-nth must-infer -\ ppush must-infer -\ ppop must-infer - [ 0 ] [ PV{ } length ] unit-test [ 1 ] [ 3 PV{ } ppush length ] unit-test diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 0479b104cc..1f72fa04ba 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -4,10 +4,6 @@ USING: regexp tools.test kernel sequences regexp.parser regexp.private eval strings multiline accessors ; IN: regexp-tests -\ must-infer -\ compile-regexp must-infer -\ matches? must-infer - [ f ] [ "b" "a*" matches? ] unit-test [ t ] [ "" "a*" matches? ] unit-test [ t ] [ "a" "a*" matches? ] unit-test diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor index df6510afbf..b8df0b7b5b 100644 --- a/basis/smtp/smtp-tests.factor +++ b/basis/smtp/smtp-tests.factor @@ -4,8 +4,6 @@ namespaces logging accessors assocs sorting smtp.private concurrency.promises system ; IN: smtp.tests -\ send-email must-infer - { 0 0 } [ [ ] with-smtp-connection ] must-infer-as [ "hello\nworld" validate-address ] must-fail diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 6ac4fce0c0..814f528cdb 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -10,7 +10,7 @@ sequences.private destructors combinators eval locals.backend system compiler.units ; IN: stack-checker.tests -\ infer. must-infer +[ 1234 infer ] must-fail { 0 2 } [ 2 "Hello" ] must-infer-as { 1 2 } [ dup ] must-infer-as @@ -65,11 +65,6 @@ IN: stack-checker.tests { 1 1 } [ simple-recursion-2 ] must-infer-as -: bad-recursion-2 ( obj -- obj ) - dup [ dup first swap second bad-recursion-2 ] [ ] if ; - -[ [ bad-recursion-2 ] infer ] must-fail - : funny-recursion ( obj -- obj ) dup [ funny-recursion 1 ] [ 2 ] if drop ; @@ -196,94 +191,11 @@ DEFER: blah4 over string? [ 2array throw ] unless ] must-infer-as -! Regression - -! This order of branches works -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 ] 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 ] must-fail - ! Regression : too-deep ( a b -- c ) dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive { 2 1 } [ too-deep ] must-infer-as -! Error reporting is wrong -MATH: xyz ( a b -- c ) -M: fixnum xyz 2array ; -M: float xyz - [ 3 ] bi@ swapd [ 2array swap ] dip 2array swap ; - -[ [ xyz ] infer ] [ inference-error? ] must-fail-with - -! Doug Coleman discovered this one while working on the -! calendar library -DEFER: A -DEFER: B -DEFER: C - -: A ( a -- ) - dup { - [ drop ] - [ A ] - [ \ A no-method ] - [ dup C A ] - } dispatch ; - -: B ( b -- ) - dup { - [ C ] - [ B ] - [ \ B no-method ] - [ dup B B ] - } dispatch ; - -: C ( c -- ) - dup { - [ A ] - [ C ] - [ \ C no-method ] - [ dup B C ] - } dispatch ; - -{ 1 0 } [ A ] must-infer-as -{ 1 0 } [ B ] must-infer-as -{ 1 0 } [ C ] must-infer-as - -! I found this bug by thinking hard about the previous one -DEFER: Y -: X ( a b -- c d ) dup [ swap Y ] [ ] if ; -: Y ( a b -- c d ) X ; - -{ 2 2 } [ X ] must-infer-as -{ 2 2 } [ Y ] must-infer-as - -! This one comes from UI code -DEFER: #1 -: #2 ( a b: ( -- ) -- ) dup [ call ] [ 2drop ] if ; inline -: #3 ( a -- ) [ #1 ] #2 ; -: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ; -: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ; - -[ \ #4 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 ] must-fail - -[ 1234 infer ] must-fail - ! This used to hang [ [ [ dup call ] dup call ] infer ] [ inference-error? ] must-fail-with @@ -311,16 +223,6 @@ DEFER: bar [ [ [ [ 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 ] must-fail - -: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; -[ [ bad-bin ] infer ] must-fail - [ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with ! Regression @@ -333,114 +235,14 @@ DEFER: bar [ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail -! Test number protocol -\ bitor must-infer -\ bitand must-infer -\ bitxor must-infer -\ mod must-infer -\ /i must-infer -\ /f must-infer -\ /mod must-infer -\ + must-infer -\ - must-infer -\ * must-infer -\ / must-infer -\ < must-infer -\ <= must-infer -\ > must-infer -\ >= must-infer -\ number= must-infer - -! Test object protocol -\ = must-infer -\ clone must-infer -\ hashcode* must-infer - -! Test sequence protocol -\ length must-infer -\ nth must-infer -\ set-length must-infer -\ set-nth must-infer -\ new must-infer -\ new-resizable must-infer -\ like must-infer -\ lengthen must-infer - -! Test assoc protocol -\ at* must-infer -\ set-at must-infer -\ new-assoc must-infer -\ delete-at must-infer -\ clear-assoc must-infer -\ assoc-size must-infer -\ assoc-like must-infer -\ assoc-clone-like must-infer -\ >alist must-infer { 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as -! Test some random library words -\ 1quotation must-infer -\ string>number must-infer -\ get must-infer - -\ push must-infer -\ append must-infer -\ peek must-infer - -\ reverse must-infer -\ member? must-infer -\ remove must-infer -\ natural-sort must-infer - -\ forget must-infer -\ define-class must-infer -\ define-tuple-class must-infer -\ define-union-class must-infer -\ define-predicate-class must-infer -\ instance? must-infer -\ next-method-quot must-infer - ! Test words with continuations { 0 0 } [ [ drop ] callcc0 ] must-infer-as { 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as { 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as { 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as -\ dispose must-infer - -! Test stream protocol -\ set-timeout must-infer -\ stream-read must-infer -\ stream-read1 must-infer -\ stream-readln must-infer -\ stream-read-until must-infer -\ stream-write must-infer -\ stream-write1 must-infer -\ stream-nl must-infer -\ stream-flush must-infer - -! Test stream utilities -\ lines must-infer -\ contents must-infer - -! Test prettyprinting -\ . must-infer -\ short. must-infer -\ unparse must-infer - -\ describe must-infer -\ error. must-infer - -! Test odds and ends -\ io-thread must-infer - -! Incorrect stack declarations on inline recursive words should -! be caught -: fooxxx ( a b -- c ) over [ foo ] when ; inline -: barxxx ( a b -- c ) fooxxx ; - -[ [ barxxx ] infer ] must-fail - ! A typo { 1 0 } [ { [ ] } dispatch ] must-infer-as @@ -463,7 +265,6 @@ DEFER: deferred-word { 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as - DEFER: an-inline-word : normal-word-3 ( -- ) @@ -503,9 +304,7 @@ ERROR: custom-error ; ] unit-test ! Regression -: missing->r-check ( a -- ) 1 load-locals ; - -[ [ missing->r-check ] infer ] must-fail +[ [ 1 load-locals ] infer ] must-fail ! Corner case [ [ [ f dup ] [ dup ] produce ] infer ] must-fail @@ -513,35 +312,12 @@ ERROR: custom-error ; [ [ [ f dup ] [ ] while ] infer ] must-fail : erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline recursive - [ [ erg's-inference-bug ] infer ] must-fail - -: inference-invalidation-a ( -- ) ; -: inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline -: inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline - -[ 7 ] [ 4 3 inference-invalidation-c ] unit-test - -{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as - -[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval( -- ) ] unit-test - -[ 3 ] [ inference-invalidation-c ] unit-test - -{ 0 1 } [ inference-invalidation-c ] must-infer-as - -GENERIC: inference-invalidation-d ( obj -- ) - -M: object inference-invalidation-d inference-invalidation-c 2drop ; - -\ inference-invalidation-d must-infer - -[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval( -- ) ] unit-test - -[ [ inference-invalidation-d ] infer ] must-fail +FORGET: erg's-inference-bug : bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline recursive [ [ bad-recursion-3 ] infer ] must-fail +FORGET: bad-recursion-3 : bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive [ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail @@ -562,6 +338,8 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ; [ [ unbalanced-retain-usage ] infer ] [ inference-error? ] must-fail-with +FORGET: unbalanced-retain-usage + DEFER: eee' : ddd' ( ? -- ) [ f eee' ] when ; inline recursive : eee' ( ? -- ) [ swap [ ] ] dip ddd' call ; inline recursive diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index abb1f2abdb..126f6a9648 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -5,7 +5,12 @@ classes classes.tuple ; : compose-n-quot ( word n -- quot' ) >quotation ; : compose-n ( quot n -- ) compose-n-quot call ; + +<< \ compose-n [ compose-n-quot ] 2 define-transform +\ compose-n t "no-compile" set-word-prop +>> + : compose-n-test ( a b c -- x ) 2 \ + compose-n ; [ 6 ] [ 1 2 3 compose-n-test ] unit-test diff --git a/basis/syndication/syndication-tests.factor b/basis/syndication/syndication-tests.factor index 3ea037352c..b0bd5a2ff5 100644 --- a/basis/syndication/syndication-tests.factor +++ b/basis/syndication/syndication-tests.factor @@ -2,9 +2,6 @@ USING: syndication io kernel io.files tools.test io.encodings.binary calendar urls xml.writer ; IN: syndication.tests -\ download-feed must-infer -\ feed>xml must-infer - : load-news-file ( filename -- feed ) #! Load an news syndication file and process it, returning #! it as an feed tuple. diff --git a/basis/tools/memory/memory-tests.factor b/basis/tools/memory/memory-tests.factor index 60b54c2a0d..4b75cf0bfa 100644 --- a/basis/tools/memory/memory-tests.factor +++ b/basis/tools/memory/memory-tests.factor @@ -1,8 +1,5 @@ USING: tools.test tools.memory ; IN: tools.memory.tests -\ room. must-infer [ ] [ room. ] unit-test - -\ heap-stats. must-infer [ ] [ heap-stats. ] unit-test diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor index 9122edcb67..ac7b33d41e 100644 --- a/basis/tools/test/test-docs.factor +++ b/basis/tools/test/test-docs.factor @@ -58,8 +58,8 @@ HELP: must-fail-with { $notes "This word is used to test error handling code, ensuring that errors thrown by code contain the relevant debugging information." } ; HELP: must-infer -{ $values { "word/quot" "a quotation or a word" } } -{ $description "Ensures that the quotation or word has a static stack effect without running it." } +{ $values { "quot" quotation } } +{ $description "Ensures that the quotation has a static stack effect without running it." } { $notes "This word is used to test that code will compile with the optimizing compiler for optimum performance. See " { $link "compiler" } "." } ; HELP: must-infer-as diff --git a/basis/tools/test/test-tests.factor b/basis/tools/test/test-tests.factor index 03f7f006c9..c8ce3e01c7 100644 --- a/basis/tools/test/test-tests.factor +++ b/basis/tools/test/test-tests.factor @@ -1,8 +1,6 @@ IN: tools.test.tests USING: tools.test tools.test.private namespaces kernel sequences ; -\ test-all must-infer - : fake-unit-test ( quot -- ) [ "fake" file set diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 1ff47e3d7f..c0c2f1892d 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -56,8 +56,7 @@ SYMBOL: file :: (must-infer-as) ( effect quot -- error ? ) [ quot infer short-effect effect assert= f f ] [ t ] recover ; -:: (must-infer) ( word/quot -- error ? ) - word/quot dup word? [ '[ _ execute ] ] when :> quot +:: (must-infer) ( quot -- error ? ) [ quot infer drop f f ] [ t ] recover ; TUPLE: did-not-fail ; diff --git a/basis/ui/event-loop/event-loop-tests.factor b/basis/ui/event-loop/event-loop-tests.factor index ae1d7ec8bc..ac263cb79c 100644 --- a/basis/ui/event-loop/event-loop-tests.factor +++ b/basis/ui/event-loop/event-loop-tests.factor @@ -1,4 +1,2 @@ IN: ui.event-loop.tests USING: ui.event-loop tools.test ; - -\ event-loop must-infer diff --git a/basis/ui/gadgets/books/books-tests.factor b/basis/ui/gadgets/books/books-tests.factor index dab9ef5acf..3076ffc004 100644 --- a/basis/ui/gadgets/books/books-tests.factor +++ b/basis/ui/gadgets/books/books-tests.factor @@ -1,4 +1,2 @@ IN: ui.gadgets.books.tests USING: tools.test ui.gadgets.books ; - -\ must-infer diff --git a/basis/ui/gadgets/buttons/buttons-tests.factor b/basis/ui/gadgets/buttons/buttons-tests.factor index 0aa12f7279..f7c73b2438 100644 --- a/basis/ui/gadgets/buttons/buttons-tests.factor +++ b/basis/ui/gadgets/buttons/buttons-tests.factor @@ -28,10 +28,6 @@ T{ foo-gadget } "t" set } "religion" set ] unit-test -\ must-infer - -\ must-infer - [ 0 ] [ "religion" get gadget-child value>> ] unit-test diff --git a/basis/ui/gadgets/editors/editors-tests.factor b/basis/ui/gadgets/editors/editors-tests.factor index bd610ba53b..3ba32dc3c2 100644 --- a/basis/ui/gadgets/editors/editors-tests.factor +++ b/basis/ui/gadgets/editors/editors-tests.factor @@ -42,8 +42,6 @@ IN: ui.gadgets.editors.tests ] with-grafted-gadget ] unit-test -\ must-infer - "hello" "field" set "field" get [ diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor index 03219c66fd..77860ba5b5 100644 --- a/basis/ui/gadgets/gadgets-tests.factor +++ b/basis/ui/gadgets/gadgets-tests.factor @@ -152,16 +152,3 @@ M: mock-gadget ungraft* { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each ] with-string-writer print - -\ must-infer -\ unparent must-infer -\ add-gadget must-infer -\ add-gadgets must-infer -\ clear-gadget must-infer - -\ relayout must-infer -\ relayout-1 must-infer -\ pref-dim must-infer - -\ graft* must-infer -\ ungraft* must-infer \ No newline at end of file diff --git a/basis/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor index 22df1f328b..4002c8b40e 100644 --- a/basis/ui/gadgets/scrollers/scrollers-tests.factor +++ b/basis/ui/gadgets/scrollers/scrollers-tests.factor @@ -104,5 +104,3 @@ dup layout model>> dependencies>> [ range-max value>> ] map { 0 0 } = ] unit-test - -\ must-infer diff --git a/basis/ui/gestures/gestures-tests.factor b/basis/ui/gestures/gestures-tests.factor index 402015ee7c..3bcea27819 100644 --- a/basis/ui/gestures/gestures-tests.factor +++ b/basis/ui/gestures/gestures-tests.factor @@ -1,5 +1,2 @@ IN: ui.gestures.tests USING: tools.test ui.gestures ; - -\ handle-gesture must-infer -\ send-queued-gesture must-infer \ No newline at end of file diff --git a/basis/ui/operations/operations-tests.factor b/basis/ui/operations/operations-tests.factor index 4612ea79b0..6e8339a539 100644 --- a/basis/ui/operations/operations-tests.factor +++ b/basis/ui/operations/operations-tests.factor @@ -26,5 +26,3 @@ io.streams.string math help help.markup accessors ; [ ] [ [ { $operations \ + } print-element ] with-string-writer drop ] unit-test - -\ object-operations must-infer \ No newline at end of file diff --git a/basis/ui/render/render-tests.factor b/basis/ui/render/render-tests.factor index 3410560ba9..3ae0082be1 100644 --- a/basis/ui/render/render-tests.factor +++ b/basis/ui/render/render-tests.factor @@ -1,4 +1,2 @@ IN: ui.render.tests USING: ui.render tools.test ; - -\ draw-gadget must-infer \ No newline at end of file diff --git a/basis/ui/tools/browser/browser-tests.factor b/basis/ui/tools/browser/browser-tests.factor index 3757f392c4..8027babc3f 100644 --- a/basis/ui/tools/browser/browser-tests.factor +++ b/basis/ui/tools/browser/browser-tests.factor @@ -1,5 +1,4 @@ IN: ui.tools.browser.tests USING: tools.test ui.gadgets.debug ui.tools.browser math ; -\ must-infer [ ] [ \ + [ ] with-grafted-gadget ] unit-test diff --git a/basis/ui/tools/inspector/inspector-tests.factor b/basis/ui/tools/inspector/inspector-tests.factor index 44e20fb0fd..2971b1e8cb 100644 --- a/basis/ui/tools/inspector/inspector-tests.factor +++ b/basis/ui/tools/inspector/inspector-tests.factor @@ -1,6 +1,4 @@ IN: ui.tools.inspector.tests USING: tools.test ui.tools.inspector math models ; -\ must-infer - [ ] [ \ + com-edit-slot ] unit-test \ No newline at end of file diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor index 986e1270eb..45b94344a6 100644 --- a/basis/ui/tools/listener/listener-tests.factor +++ b/basis/ui/tools/listener/listener-tests.factor @@ -6,8 +6,6 @@ threads arrays generic threads accessors listener math calendar concurrency.promises io ui.tools.common ; IN: ui.tools.listener.tests -\ must-infer - [ [ ] [ >>output "interactor" set ] unit-test diff --git a/basis/ui/tools/profiler/profiler-tests.factor b/basis/ui/tools/profiler/profiler-tests.factor index 86bebddbc9..c1c8fdbff9 100644 --- a/basis/ui/tools/profiler/profiler-tests.factor +++ b/basis/ui/tools/profiler/profiler-tests.factor @@ -1,3 +1,3 @@ USING: ui.tools.profiler tools.test ; -\ profiler-window must-infer + diff --git a/basis/ui/tools/walker/walker-tests.factor b/basis/ui/tools/walker/walker-tests.factor index fefb188239..fe0b57b980 100644 --- a/basis/ui/tools/walker/walker-tests.factor +++ b/basis/ui/tools/walker/walker-tests.factor @@ -1,4 +1,3 @@ USING: ui.tools.walker tools.test ; IN: ui.tools.walker.tests -\ must-infer diff --git a/basis/ui/ui-tests.factor b/basis/ui/ui-tests.factor index 4b4bf9d9ee..06de4eb9c2 100644 --- a/basis/ui/ui-tests.factor +++ b/basis/ui/ui-tests.factor @@ -1,5 +1,2 @@ IN: ui.tests USING: ui ui.private tools.test ; - -\ open-window must-infer -\ update-ui must-infer \ No newline at end of file diff --git a/basis/unicode/case/case-tests.factor b/basis/unicode/case/case-tests.factor index a76f5e78c4..9344d1102e 100644 --- a/basis/unicode/case/case-tests.factor +++ b/basis/unicode/case/case-tests.factor @@ -4,10 +4,6 @@ USING: unicode.case tools.test namespaces strings unicode.normalize unicode.case.private ; IN: unicode.case.tests -\ >upper must-infer -\ >lower must-infer -\ >title must-infer - [ "Hello How Are You? I'm Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test [ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test [ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor index 2e989b32c0..eae2020077 100644 --- a/basis/unix/groups/groups-tests.factor +++ b/basis/unix/groups/groups-tests.factor @@ -5,8 +5,6 @@ IN: unix.groups.tests [ ] [ all-groups drop ] unit-test -\ all-groups must-infer - [ t ] [ real-group-name string? ] unit-test [ t ] [ effective-group-name string? ] unit-test diff --git a/basis/unix/users/users-tests.factor b/basis/unix/users/users-tests.factor index f2a4b7bc27..cf3747b346 100644 --- a/basis/unix/users/users-tests.factor +++ b/basis/unix/users/users-tests.factor @@ -3,11 +3,8 @@ USING: tools.test unix.users kernel strings math ; IN: unix.users.tests - [ ] [ all-users drop ] unit-test -\ all-users must-infer - [ t ] [ real-user-name string? ] unit-test [ t ] [ effective-user-name string? ] unit-test diff --git a/basis/wrap/strings/strings-tests.factor b/basis/wrap/strings/strings-tests.factor index e66572dc1b..07f42caae3 100644 --- a/basis/wrap/strings/strings-tests.factor +++ b/basis/wrap/strings/strings-tests.factor @@ -38,6 +38,4 @@ word wrap."> [ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test [ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test -\ wrap-string must-infer - [ "a b c d e f\ng h" ] [ "a b c d e f g h" 11 wrap-string ] unit-test diff --git a/basis/wrap/words/words-tests.factor b/basis/wrap/words/words-tests.factor index 7598b382ba..6df69a65d6 100644 --- a/basis/wrap/words/words-tests.factor +++ b/basis/wrap/words/words-tests.factor @@ -79,4 +79,3 @@ IN: wrap.words.tests } 35 35 wrap-words [ { } like ] map ] unit-test -\ wrap-words must-infer diff --git a/basis/xml/syntax/syntax-tests.factor b/basis/xml/syntax/syntax-tests.factor index 10ab961ec0..6fcaf780cc 100644 --- a/basis/xml/syntax/syntax-tests.factor +++ b/basis/xml/syntax/syntax-tests.factor @@ -33,8 +33,6 @@ TAG: neg calculate calc-arith ] unit-test -\ calc-arith must-infer - XML-NS: foo http://blah.com [ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test @@ -90,7 +88,6 @@ XML-NS: foo http://blah.com [ "3" ] [ 3 [XML <-> XML] xml>string ] unit-test [ "" ] [ f [XML <-> XML] xml>string ] unit-test -\ XML] ] must-infer [ [XML <-> /> XML] ] must-infer diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor index 1d07aa9406..74ba931c79 100644 --- a/basis/xml/tests/test.factor +++ b/basis/xml/tests/test.factor @@ -7,9 +7,7 @@ xml.traversal continuations assocs io.encodings.binary sequences.deep accessors io.streams.string ; ! This is insufficient -\ read-xml must-infer [ [ drop ] each-element ] must-infer -\ string>xml must-infer SYMBOL: xml-file [ ] [ diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor index 2d31738c4c..ee09668a53 100644 --- a/basis/xml/writer/writer-tests.factor +++ b/basis/xml/writer/writer-tests.factor @@ -5,9 +5,6 @@ xml.writer.private io.streams.string xml.traversal sequences io.encodings.utf8 io.files accessors io.directories math math.parser ; IN: xml.writer.tests -\ write-xml must-infer -\ xml>string must-infer -\ pprint-xml must-infer ! Add a test for pprint-xml with sensitive-tags [ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test diff --git a/basis/xmode/code2html/code2html-tests.factor b/basis/xmode/code2html/code2html-tests.factor index 8d5db4a6e9..d57b8ce28d 100644 --- a/basis/xmode/code2html/code2html-tests.factor +++ b/basis/xmode/code2html/code2html-tests.factor @@ -3,8 +3,6 @@ USING: xmode.code2html xmode.catalog tools.test multiline splitting memoize kernel io.streams.string xml.writer ; -\ htmlize-file must-infer - [ ] [ \ (load-mode) reset-memoized ] unit-test [ ] [ diff --git a/core/checksums/checksums-tests.factor b/core/checksums/checksums-tests.factor index 1ec675b0cf..8ba09d8e91 100644 --- a/core/checksums/checksums-tests.factor +++ b/core/checksums/checksums-tests.factor @@ -1,7 +1,3 @@ IN: checksums.tests USING: checksums tools.test ; -\ checksum-bytes must-infer -\ checksum-stream must-infer -\ checksum-lines must-infer -\ checksum-file must-infer diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index a3610ff7c5..a6af5b8c29 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -7,12 +7,6 @@ random stack-checker effects kernel.private sbufs math.order classes.tuple accessors ; IN: classes.algebra.tests -\ class< must-infer -\ class-and must-infer -\ class-or must-infer -\ flatten-class must-infer -\ flatten-builtin-class must-infer - : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ; : class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 68cdc20c53..3800d5056a 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -599,7 +599,7 @@ must-fail-with : foo ( a b -- c ) declared-types boa ; -\ foo must-infer +\ foo def>> must-infer [ T{ declared-types f 0 "hi" } ] [ 0.0 "hi" foo ] unit-test diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index a8049f709e..dd5fa06031 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -42,7 +42,7 @@ IN: combinators.tests { [ dup 2 mod 1 = ] [ drop "odd" ] } } cond ; -\ cond-test-1 must-infer +\ cond-test-1 def>> must-infer [ "even" ] [ 2 cond-test-1 ] unit-test [ "odd" ] [ 3 cond-test-1 ] unit-test @@ -54,7 +54,7 @@ IN: combinators.tests [ drop "something else" ] } cond ; -\ cond-test-2 must-infer +\ cond-test-2 def>> must-infer [ "true" ] [ t cond-test-2 ] unit-test [ "false" ] [ f cond-test-2 ] unit-test @@ -67,7 +67,7 @@ IN: combinators.tests { [ dup f = ] [ drop "false" ] } } cond ; -\ cond-test-3 must-infer +\ cond-test-3 def>> must-infer [ "something else" ] [ t cond-test-3 ] unit-test [ "something else" ] [ f cond-test-3 ] unit-test @@ -77,7 +77,7 @@ IN: combinators.tests { } cond ; -\ cond-test-4 must-infer +\ cond-test-4 def>> must-infer [ cond-test-4 ] [ class \ no-cond = ] must-fail-with @@ -168,7 +168,7 @@ IN: combinators.tests { 4 [ "four" ] } } case ; -\ case-test-1 must-infer +\ case-test-1 def>> must-infer [ "two" ] [ 2 case-test-1 ] unit-test @@ -186,7 +186,7 @@ IN: combinators.tests [ sq ] } case ; -\ case-test-2 must-infer +\ case-test-2 def>> must-infer [ 25 ] [ 5 case-test-2 ] unit-test @@ -204,7 +204,7 @@ IN: combinators.tests [ sq ] } case ; -\ case-test-3 must-infer +\ case-test-3 def>> must-infer [ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test @@ -222,7 +222,7 @@ CONSTANT: case-const-2 2 [ drop "demasiado" ] } case ; -\ case-test-4 must-infer +\ case-test-4 def>> must-infer [ "uno" ] [ 1 case-test-4 ] unit-test [ "dos" ] [ 2 case-test-4 ] unit-test @@ -239,7 +239,7 @@ CONSTANT: case-const-2 2 [ drop "demasiado" print ] } case ; -\ case-test-5 must-infer +\ case-test-5 def>> must-infer [ ] [ 1 case-test-5 ] unit-test @@ -296,7 +296,7 @@ CONSTANT: case-const-2 2 { 3 [ "three" ] } } case ; -\ test-case-6 must-infer +\ test-case-6 def>> must-infer [ "three" ] [ 3 test-case-6 ] unit-test [ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test @@ -343,7 +343,7 @@ CONSTANT: case-const-2 2 { \ ] [ "KFC" ] } } case ; -\ test-case-7 must-infer +\ test-case-7 def>> must-infer [ "plus" ] [ \ + test-case-7 ] unit-test diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 2111cce358..391b87a44f 100644 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -107,4 +107,4 @@ SYMBOL: error-counter [ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test -\ with-datastack must-infer +[ with-datastack ] must-infer diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index a2d637dcb7..8f0fb9e97a 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -4,9 +4,6 @@ io.files io.files.private io.files.temp io.files.unique kernel make math sequences system threads tools.test generic.standard ; IN: io.files.tests -\ exists? must-infer -\ (exists?) must-infer - [ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test [ ] [ "append-test" temp-file ascii dispose ] unit-test diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 2add8663d8..a8a57ccdaa 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -6,8 +6,6 @@ vocabs vocabs.loader accessors eval combinators lexer vocabs.parser words.symbol multiline source-files.errors ; IN: parser.tests -\ run-file must-infer - [ [ 1 [ 2 [ 3 ] 4 ] 5 ] [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval( -- a b c ) ] diff --git a/extra/contributors/contributors-tests.factor b/extra/contributors/contributors-tests.factor index 1476715588..3d9ce0403d 100644 --- a/extra/contributors/contributors-tests.factor +++ b/extra/contributors/contributors-tests.factor @@ -1,5 +1,4 @@ IN: contributors.tests USING: contributors tools.test ; -\ contributors must-infer [ ] [ contributors ] unit-test diff --git a/extra/infix/parser/parser-tests.factor b/extra/infix/parser/parser-tests.factor index d6b5d0559c..fa598a4ac6 100644 --- a/extra/infix/parser/parser-tests.factor +++ b/extra/infix/parser/parser-tests.factor @@ -3,9 +3,6 @@ USING: infix.ast infix.parser infix.tokenizer tools.test ; IN: infix.parser.tests -\ parse-infix must-infer -\ build-infix-ast must-infer - [ T{ ast-number { value 1 } } ] [ "1" build-infix-ast ] unit-test [ T{ ast-negation f T{ ast-number { value 1 } } } ] [ "-1" build-infix-ast ] unit-test diff --git a/extra/infix/tokenizer/tokenizer-tests.factor b/extra/infix/tokenizer/tokenizer-tests.factor index f9c908414a..b068881b84 100644 --- a/extra/infix/tokenizer/tokenizer-tests.factor +++ b/extra/infix/tokenizer/tokenizer-tests.factor @@ -3,7 +3,6 @@ USING: infix.ast infix.tokenizer tools.test ; IN: infix.tokenizer.tests -\ tokenize-infix must-infer [ V{ T{ ast-number f 1 } } ] [ "1" tokenize-infix ] unit-test [ V{ T{ ast-number f 1.02 } CHAR: * T{ ast-number f 3 } } ] [ "1.02*3" tokenize-infix ] unit-test [ V{ T{ ast-number f 3 } CHAR: / CHAR: ( T{ ast-number f 3 } CHAR: + T{ ast-number f 4 } CHAR: ) } ] diff --git a/extra/mason/cleanup/cleanup-tests.factor b/extra/mason/cleanup/cleanup-tests.factor index 9158536ffb..49a5153a8e 100644 --- a/extra/mason/cleanup/cleanup-tests.factor +++ b/extra/mason/cleanup/cleanup-tests.factor @@ -1,4 +1,2 @@ USING: tools.test mason.cleanup ; IN: mason.cleanup.tests - -\ cleanup must-infer diff --git a/extra/mason/release/upload/upload-tests.factor b/extra/mason/release/upload/upload-tests.factor index 73fc311399..09f1e13ae9 100644 --- a/extra/mason/release/upload/upload-tests.factor +++ b/extra/mason/release/upload/upload-tests.factor @@ -1,4 +1,3 @@ IN: mason.release.upload.tests USING: mason.release.upload tools.test ; -\ upload must-infer diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor index 240c9f86d7..aa66f41d8d 100644 --- a/extra/multi-methods/tests/definitions.factor +++ b/extra/multi-methods/tests/definitions.factor @@ -2,9 +2,6 @@ IN: multi-methods.tests USING: multi-methods tools.test math sequences namespaces system kernel strings words compiler.units quotations ; -\ GENERIC: must-infer -\ create-method-in must-infer - DEFER: fake \ fake H{ } clone "multi-methods" set-word-prop diff --git a/extra/peg/javascript/javascript-tests.factor b/extra/peg/javascript/javascript-tests.factor index 0d6899714d..69223a418d 100644 --- a/extra/peg/javascript/javascript-tests.factor +++ b/extra/peg/javascript/javascript-tests.factor @@ -4,8 +4,6 @@ USING: kernel tools.test peg.javascript peg.javascript.ast accessors ; IN: peg.javascript.tests -\ parse-javascript must-infer - { T{ ast-begin f V{ T{ ast-number f 123 } } } } [ "123;" parse-javascript ] unit-test \ No newline at end of file diff --git a/extra/peg/javascript/parser/parser-tests.factor b/extra/peg/javascript/parser/parser-tests.factor index a2c50952be..a521202b1c 100644 --- a/extra/peg/javascript/parser/parser-tests.factor +++ b/extra/peg/javascript/parser/parser-tests.factor @@ -5,8 +5,6 @@ USING: kernel tools.test peg peg.javascript.ast peg.javascript.parser accessors multiline sequences math peg.ebnf ; IN: peg.javascript.parser.tests -\ javascript must-infer - { T{ ast-begin diff --git a/extra/peg/javascript/tokenizer/tokenizer-tests.factor b/extra/peg/javascript/tokenizer/tokenizer-tests.factor index f0080a31b2..0fbd55ccfd 100644 --- a/extra/peg/javascript/tokenizer/tokenizer-tests.factor +++ b/extra/peg/javascript/tokenizer/tokenizer-tests.factor @@ -4,8 +4,6 @@ USING: kernel tools.test peg peg.javascript.ast peg.javascript.tokenizer accessors ; IN: peg.javascript.tokenizer.tests -\ tokenize-javascript must-infer - { V{ T{ ast-number f 123 } From 1e21f0ef4373d07bb4050b73aa7721b8329b457d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 21:17:18 -0500 Subject: [PATCH 63/98] better docs for emacs setup --- basis/editors/emacs/authors.txt | 1 + basis/editors/emacs/emacs-docs.factor | 19 ++++++++++++++++--- 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/basis/editors/emacs/authors.txt b/basis/editors/emacs/authors.txt index 6cfd5da273..07c1c4a765 100644 --- a/basis/editors/emacs/authors.txt +++ b/basis/editors/emacs/authors.txt @@ -1 +1,2 @@ Eduardo Cavazos +Doug Coleman diff --git a/basis/editors/emacs/emacs-docs.factor b/basis/editors/emacs/emacs-docs.factor index f55068e143..adf6d8a7b7 100644 --- a/basis/editors/emacs/emacs-docs.factor +++ b/basis/editors/emacs/emacs-docs.factor @@ -2,10 +2,23 @@ USING: help help.syntax help.markup ; IN: editors.emacs ARTICLE: "editors.emacs" "Integration with Emacs" -"Put this in your " { $snippet ".emacs" } " file:" +"Full Emacs integration with Factor requires the use of two executable files -- " { $snippet "emacs" } " and " { $snippet "emacsclient" } ", which act as a client/server pair. To start the server, run the " { $snippet "emacs" } " binary and run " { $snippet "M-x server-start" } " or start " { $snippet "emacs" } " with the following line in your " { $snippet ".emacs" } " file:" { $code "(server-start)" } +"On Windows, if you install Emacs to " { $snippet "Program Files" } " or " { $snippet "Program Files(x86)" } ", Factor will automatically detect the path to " { $snippet "emacsclient.exe" } ". On Unix systems, make sure that " { $snippet "emacsclient" } " is in your path. To set the path manually, use the following snippet:" +{ $code "USE: edtiors.emacs" + "\"/my/crazy/bin/emacsclient\" emacsclient-path set-global" +} + "If you would like a new window to open when you ask Factor to edit an object, put this in your " { $snippet ".emacs" } " file:" { $code "(setq server-window 'switch-to-buffer-other-frame)" } -{ $see-also "editor" } ; -ABOUT: "editors.emacs" \ No newline at end of file +"To quickly scaffold a " { $snippet ".emacs" } " file, run the following code:" +{ $code "USE: tools.scaffold" + "scaffold-emacs" +} + +{ $see-also "editor" } + +; + +ABOUT: "editors.emacs" From 687190bbeebd5687d6392afc7030a1db03999920 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 21:32:23 -0500 Subject: [PATCH 64/98] fix a bug in db.tester --- basis/db/tester/tester.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/db/tester/tester.factor b/basis/db/tester/tester.factor index fcc5abf1cf..a700e3eaa2 100644 --- a/basis/db/tester/tester.factor +++ b/basis/db/tester/tester.factor @@ -3,7 +3,7 @@ USING: concurrency.combinators db.pools db.sqlite db.tuples db.types kernel math random threads tools.test db sequences io prettyprint db.postgresql db.sqlite accessors io.files.temp -namespaces fry system ; +namespaces fry system math.parser ; IN: db.tester : postgresql-test-db ( -- postgresql-db ) @@ -67,8 +67,8 @@ test-2 "TEST2" { drop 10 [ dup [ - f 100 random 100 random 100 random test-1 boa - insert-tuple yield + f 100 random 100 random 100 random [ number>string ] tri@ + test-1 boa insert-tuple yield ] with-db ] times ] with parallel-each From 706fb78d5b9ff3a9f905539e0cbee3a39ea29685 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 21:47:16 -0500 Subject: [PATCH 65/98] better fix for db.tester --- basis/db/tester/tester.factor | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/basis/db/tester/tester.factor b/basis/db/tester/tester.factor index a700e3eaa2..56bac7efcd 100644 --- a/basis/db/tester/tester.factor +++ b/basis/db/tester/tester.factor @@ -56,6 +56,10 @@ test-2 "TEST2" { { "z" "Z" { VARCHAR 256 } +not-null+ } } define-persistent +: test-1-tuple ( -- tuple ) + f 100 random 100 random 100 random [ number>string ] tri@ + test-1 boa ; + : db-tester ( test-db -- ) [ [ @@ -67,8 +71,7 @@ test-2 "TEST2" { drop 10 [ dup [ - f 100 random 100 random 100 random [ number>string ] tri@ - test-1 boa insert-tuple yield + test-1-tuple insert-tuple yield ] with-db ] times ] with parallel-each @@ -84,8 +87,7 @@ test-2 "TEST2" { [ 10 [ 10 [ - f 100 random 100 random 100 random test-1 boa - insert-tuple yield + test-1-tuple insert-tuple yield ] times ] parallel-each ] with-pooled-db From f38d2f91f62e1495b718d90d12957b82955eaff5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 22:05:41 -0500 Subject: [PATCH 66/98] Words which didn't compile cannot be run at all --- basis/compiler/compiler.factor | 17 ++++++++++++----- basis/compiler/errors/errors.factor | 2 ++ basis/compiler/tree/builder/builder.factor | 4 ++-- basis/stack-checker/errors/errors.factor | 4 ++-- .../errors/prettyprint/prettyprint.factor | 5 +---- basis/tools/errors/errors.factor | 8 +++++++- core/compiler/units/units-docs.factor | 4 ++-- core/compiler/units/units-tests.factor | 2 +- core/compiler/units/units.factor | 2 +- vm/code_heap.c | 18 +++++++++++------- vm/code_heap.h | 2 +- vm/quotations.c | 3 +-- vm/types.c | 2 +- 13 files changed, 44 insertions(+), 29 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 7c53e41377..b8ba620f32 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -62,18 +62,25 @@ SYMBOLS: +optimized+ +unoptimized+ ; } 1|| ] [ error-type +compiler-warning+ eq? ] bi* and ; -: (fail) ( word -- * ) +: (fail) ( word compiled -- * ) + swap [ compiled-unxref ] - [ f swap compiled get set-at ] + [ compiled get set-at ] [ +unoptimized+ save-compiled-status ] tri return ; +: not-compiled-def ( word error -- def ) + '[ _ _ not-compiled ] [ ] like ; + : fail ( word error -- * ) - [ 2dup ignore-error? [ drop f ] when swap compiler-error ] [ drop (fail) ] 2bi ; + 2dup ignore-error? + [ drop f over def>> ] + [ 2dup not-compiled-def ] if + [ swap compiler-error ] [ (fail) ] bi-curry* bi ; : frontend ( word -- nodes ) - dup contains-breakpoints? [ (fail) ] [ + dup contains-breakpoints? [ dup def>> (fail) ] [ [ build-tree-from-word ] [ fail ] recover optimize-tree ] if ; @@ -124,7 +131,7 @@ t compile-dependencies? set-global [ (compile) yield-hook get call( -- ) ] slurp-deque ; : decompile ( word -- ) - f 2array 1array modify-code-heap ; + dup def>> 2array 1array modify-code-heap ; : compile-call ( quot -- ) [ dup infer define-temp ] with-compilation-unit execute ; diff --git a/basis/compiler/errors/errors.factor b/basis/compiler/errors/errors.factor index 22ae8d97ff..7e2f3d95f8 100644 --- a/basis/compiler/errors/errors.factor +++ b/basis/compiler/errors/errors.factor @@ -52,3 +52,5 @@ T{ error-type : compiler-error ( error word -- ) compiler-errors get-global pick [ [ [ ] keep ] dip set-at ] [ delete-at drop ] if ; + +ERROR: not-compiled word error ; \ No newline at end of file diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index edea9ae6c0..bda64569c3 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -45,8 +45,8 @@ IN: compiler.tree.builder infer-quot-here ; : check-effect ( word effect -- ) - over required-stack-effect 2dup effect<= - [ 3drop ] [ effect-error ] if ; + swap required-stack-effect 2dup effect<= + [ 2drop ] [ effect-error ] if ; : finish-word ( word -- ) current-effect check-effect ; diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index cb45d65954..550e283dbf 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -52,9 +52,9 @@ TUPLE: missing-effect word ; : missing-effect ( word -- * ) pretty-word \ missing-effect inference-error ; -TUPLE: effect-error word inferred declared ; +TUPLE: effect-error inferred declared ; -: effect-error ( word inferred declared -- * ) +: effect-error ( inferred declared -- * ) \ effect-error inference-error ; TUPLE: recursive-quotation-error quot ; diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index d6cee8e08f..97fe1522e0 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -40,10 +40,7 @@ M: missing-effect summary ] "" make ; M: effect-error summary - [ - "Stack effect declaration of the word " % - word>> name>> % " is wrong" % - ] "" make ; + drop "Stack effect declaration is wrong" ; M: recursive-quotation-error error. "The quotation " write diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor index 0a28bdec08..422e08f020 100644 --- a/basis/tools/errors/errors.factor +++ b/basis/tools/errors/errors.factor @@ -39,4 +39,10 @@ M: source-file-error error. : :warnings ( -- ) +compiler-warning+ compiler-errors. ; -: :linkage ( -- ) +linkage-error+ compiler-errors. ; \ No newline at end of file +: :linkage ( -- ) +linkage-error+ compiler-errors. ; + +M: not-compiled summary + word>> name>> "The word " " cannot be executed because it failed to compile" surround ; + +M: not-compiled error. + [ summary print nl ] [ error>> error. ] bi ; \ No newline at end of file diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor index bf3b4a7171..94a95ac9c3 100644 --- a/core/compiler/units/units-docs.factor +++ b/core/compiler/units/units-docs.factor @@ -60,8 +60,8 @@ HELP: modify-code-heap ( alist -- ) { $values { "alist" "an alist" } } { $description "Stores compiled code definitions in the code heap. The alist maps words to the following:" { $list - { { $link f } " - in this case, the word is compiled with the non-optimizing compiler part of the VM." } - { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data." } + { "a quotation - in this case, the quotation is compiled with the non-optimizing compiler and the word will call the quotation when executed." } + { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data and the word will call the code block when executed." } } } { $notes "This word is called at the end of " { $link with-compilation-unit } "." } ; diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index 03c68815cc..57726cc269 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -14,7 +14,7 @@ IN: compiler.units.tests ! Non-optimizing compiler bugs [ 1 1 ] [ - "A" "B" [ [ 1 ] dip ] >>def dup f 2array 1array modify-code-heap + "A" "B" [ [ 1 ] dip ] 2array 1array modify-code-heap 1 swap execute ] unit-test diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index a278bf0d5e..02a80c4d84 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -41,7 +41,7 @@ SYMBOL: compiler-impl HOOK: recompile compiler-impl ( words -- alist ) ! Non-optimizing compiler -M: f recompile [ f ] { } map>assoc ; +M: f recompile [ dup def>> ] { } map>assoc ; ! Trivial compiler. We don't want to touch the code heap ! during stage1 bootstrap, it would just waste time. diff --git a/vm/code_heap.c b/vm/code_heap.c index 65a28c6de3..1901c592e6 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -21,14 +21,16 @@ void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled) word->optimizedp = T; } -/* Allocates memory */ -void default_word_code(F_WORD *word, bool relocate) +/* Compile a word definition with the non-optimizing compiler. Allocates memory */ +void jit_compile_word(F_WORD *word, CELL def, bool relocate) { + REGISTER_ROOT(def); REGISTER_UNTAGGED(word); - jit_compile(word->def,relocate); + jit_compile(def,relocate); UNREGISTER_UNTAGGED(word); + UNREGISTER_ROOT(def); - word->code = untag_quotation(word->def)->code; + word->code = untag_quotation(def)->code; word->optimizedp = F; } @@ -83,15 +85,15 @@ void primitive_modify_code_heap(void) CELL data = array_nth(pair,1); - if(data == F) + if(type_of(data) == QUOTATION_TYPE) { REGISTER_UNTAGGED(alist); REGISTER_UNTAGGED(word); - default_word_code(word,false); + jit_compile_word(word,data,false); UNREGISTER_UNTAGGED(word); UNREGISTER_UNTAGGED(alist); } - else + else if(type_of(data) == ARRAY_TYPE) { F_ARRAY *compiled_code = untag_array(data); @@ -115,6 +117,8 @@ void primitive_modify_code_heap(void) set_word_code(word,compiled); } + else + critical_error("Expected a quotation or an array",data); REGISTER_UNTAGGED(alist); update_word_xt(word); diff --git a/vm/code_heap.h b/vm/code_heap.h index 4f52819547..4c5aafcddd 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -5,7 +5,7 @@ void init_code_heap(CELL size); bool in_code_heap_p(CELL ptr); -void default_word_code(F_WORD *word, bool relocate); +void jit_compile_word(F_WORD *word, CELL def, bool relocate); void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled); diff --git a/vm/quotations.c b/vm/quotations.c index e18e6b6098..f56ab6eada 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -532,8 +532,7 @@ void compile_all_words(void) { F_WORD *word = untag_word(array_nth(untag_array(words),i)); REGISTER_UNTAGGED(word); - if(word->optimizedp == F) - default_word_code(word,false); + jit_compile_word(word,word->def,false); UNREGISTER_UNTAGGED(word); update_word_xt(word); } diff --git a/vm/types.c b/vm/types.c index 119dc675bc..889de38016 100755 --- a/vm/types.c +++ b/vm/types.c @@ -54,7 +54,7 @@ F_WORD *allot_word(CELL vocab, CELL name) word->code = NULL; REGISTER_UNTAGGED(word); - default_word_code(word,true); + jit_compile_word(word,word->def,true); UNREGISTER_UNTAGGED(word); REGISTER_UNTAGGED(word); From 2f0058e46ab0c50e7cbb6648a67a132625860bb6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 23:23:16 -0500 Subject: [PATCH 67/98] factor.sh now has an exit routine. it will print _something_ so it doesn't loop when looking for a make target --- build-support/factor.sh | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index 53aab9ad04..3ece72306a 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -22,6 +22,13 @@ test_program_installed() { return 1; } +exit_script() { + if [[ $FIND_MAKE_TARGET -eq true ]] ; then + echo $MAKE_TARGET; + fi + exit $1 +} + ensure_program_installed() { installed=0; for i in $* ; @@ -43,7 +50,7 @@ ensure_program_installed() { $ECHO -n "any of [ $* ]" fi $ECHO " and try again." - exit 1 + exit_script 1; fi } @@ -51,7 +58,7 @@ check_ret() { RET=$? if [[ $RET -ne 0 ]] ; then $ECHO $1 failed - exit 2 + exit_script 2 fi } @@ -62,7 +69,7 @@ check_gcc_version() { if [[ $GCC_VERSION == *3.3.* ]] ; then $ECHO "You have a known buggy version of gcc (3.3)" $ECHO "Install gcc 3.4 or higher and try again." - exit 3 + exit_script 3 elif [[ $GCC_VERSION == *4.3.* ]] ; then MAKE_OPTS="$MAKE_OPTS SITE_CFLAGS=-fno-forward-propagate" fi @@ -154,7 +161,7 @@ check_factor_exists() { if [[ -d "factor" ]] ; then $ECHO "A directory called 'factor' already exists." $ECHO "Rename or delete it and try again." - exit 4 + exit_script 4 fi } @@ -279,7 +286,7 @@ check_os_arch_word() { $ECHO "OS, ARCH, or WORD is empty. Please report this." echo $MAKE_TARGET - exit 5 + exit_script 5 fi } @@ -385,7 +392,7 @@ check_makefile_exists() { echo "You are likely in the wrong directory." echo "Run this script from your factor directory:" echo " ./build-support/factor.sh" - exit 6 + exit_script 6 fi } @@ -536,6 +543,6 @@ case "$1" in bootstrap) get_config_info; bootstrap ;; report) find_build_info ;; net-bootstrap) get_config_info; update_boot_images; bootstrap ;; - make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;; + make-target) FIND_MAKE_TARGET=true; ECHO=false; find_build_info; exit_script ;; *) usage ;; esac From cb6205e9d490d97f5ac4bd6073b4b2389d5817d4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 00:04:56 -0500 Subject: [PATCH 68/98] debugger: add summary method for VM errors --- basis/debugger/debugger.factor | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 9abd5a9033..d8ebd5bbf9 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -126,14 +126,14 @@ HOOK: signal-error. os ( obj -- ) : primitive-error. ( error -- ) "Unimplemented primitive" print drop ; -PREDICATE: kernel-error < array +PREDICATE: vm-error < array { { [ dup empty? ] [ drop f ] } { [ dup first "kernel-error" = not ] [ drop f ] } [ second 0 15 between? ] } cond ; -: kernel-errors ( error -- n errors ) +: vm-errors ( error -- n errors ) second { { 0 [ expired-error. ] } { 1 [ io-error. ] } @@ -153,9 +153,11 @@ PREDICATE: kernel-error < array { 15 [ memory-error. ] } } ; inline -M: kernel-error error. dup kernel-errors case ; +M: vm-error summary drop "VM error" ; -M: kernel-error error-help kernel-errors at first ; +M: vm-error error. dup vm-errors case ; + +M: vm-error error-help vm-errors at first ; M: no-method summary drop "No suitable method" ; From 461ddfac1afa1730055a3b414de82354a964dc1d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 00:05:39 -0500 Subject: [PATCH 69/98] Fix 'become' --- core/memory/memory-tests.factor | 2 ++ vm/data_gc.c | 6 ++++++ vm/quotations.c | 3 ++- 3 files changed, 10 insertions(+), 1 deletion(-) diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index 670c21d6ff..a6ecdc005e 100644 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -3,6 +3,8 @@ sequences tools.test words namespaces layouts classes classes.builtin arrays quotations io.launcher system ; IN: memory.tests +[ ] [ { } { } become ] unit-test + ! LOL [ ] [ vm diff --git a/vm/data_gc.c b/vm/data_gc.c index 2252d07541..cc1df13d58 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -564,6 +564,8 @@ void primitive_clear_gc_stats(void) clear_gc_stats(); } +/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this + to coalesce equal but distinct quotations and wrappers. */ void primitive_become(void) { F_ARRAY *new_objects = untag_array(dpop()); @@ -585,5 +587,9 @@ void primitive_become(void) gc(); + /* If a word's definition quotation was in old_objects and the + quotation in new_objects is not compiled, we might leak memory + by referencing the old quotation unless we recompile all + unoptimized words. */ compile_all_words(); } diff --git a/vm/quotations.c b/vm/quotations.c index f56ab6eada..d08fecdefb 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -532,7 +532,8 @@ void compile_all_words(void) { F_WORD *word = untag_word(array_nth(untag_array(words),i)); REGISTER_UNTAGGED(word); - jit_compile_word(word,word->def,false); + if(word->optimizedp == F) + jit_compile_word(word,word->def,false); UNREGISTER_UNTAGGED(word); update_word_xt(word); } From 782a2beff3e707693446c19fac48f5659f1b5f72 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 00:14:30 -0500 Subject: [PATCH 70/98] tweak error list sorting, listener now shows error list summary in a separate pane --- basis/ui/tools/error-list/error-list.factor | 2 +- basis/ui/tools/listener/listener.factor | 40 ++++++++++++--------- 2 files changed, 25 insertions(+), 17 deletions(-) diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index 6a63a70cf8..42863a8fd2 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -97,7 +97,7 @@ M: error-renderer column-titles M: error-renderer column-alignment drop { 0 1 0 0 } ; : sort-errors ( seq -- seq' ) - [ [ [ asset>> unparse-short ] [ line#>> ] bi 2array ] keep ] { } map>assoc + [ [ [ line#>> ] [ asset>> unparse-short ] bi 2array ] keep ] { } map>assoc sort-keys values ; : file-matches? ( error pathname/f -- ? ) diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 6484b8e1c4..249be0b291 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -32,9 +32,10 @@ output history flag mailbox thread waiting token-model word-model popup ; : interactor-busy? ( interactor -- ? ) #! We're busy if there's no thread to resume. - [ waiting>> ] - [ thread>> dup [ thread-registered? ] when ] - bi and not ; + { + [ waiting>> ] + [ thread>> dup [ thread-registered? ] when ] + } 1&& not ; SLOT: vocabs @@ -171,7 +172,7 @@ M: interactor dispose drop ; over set-caret mark>caret ; -TUPLE: listener-gadget < tool input output scroller ; +TUPLE: listener-gadget < tool error-summary output scroller input ; { 600 700 } listener-gadget set-tool-dim @@ -181,17 +182,22 @@ TUPLE: listener-gadget < tool input output scroller ; : listener-streams ( listener -- input output ) [ input>> ] [ output>> ] bi ; -: init-listener ( listener -- listener ) +: init-input/output ( listener -- listener ) [ >>input ] [ pane new-pane t >>scrolls? >>output ] bi dup listener-streams >>output drop ; -: ( -- gadget ) +: init-error-summary ( listener -- listener ) + >>error-summary + dup error-summary>> f track-add ; + +: ( -- listener ) vertical listener-gadget new-track add-toolbar - init-listener + init-input/output dup output>> >>scroller - dup scroller>> 1 track-add ; + dup scroller>> 1 track-add + init-error-summary ; M: listener-gadget focusable-child* input>> dup popup>> or ; @@ -357,18 +363,20 @@ interactor "completion" f { { T{ key-down f { C+ } "r" } history-completion-popup } } define-command-map -: ui-error-summary ( -- ) - error-counts keys [ - [ icon>> 1array \ $image prefix " " 2array ] { } map-as - { "Press " { $command tool "common" show-error-list } " to view errors." } - append print-element nl - ] unless-empty ; +: ui-error-summary ( listener -- ) + error-summary>> [ + error-counts keys [ + [ icon>> 1array \ $image prefix " " 2array ] { } map-as + { "Press " { $command tool "common" show-error-list } " to view errors." } + append print-element + ] unless-empty + ] with-pane ; : listener-thread ( listener -- ) dup listener-streams [ [ com-browse ] help-hook set - '[ [ _ input>> ] 2dip debugger-popup ] error-hook set - [ ui-error-summary ] error-summary-hook set + [ '[ [ _ input>> ] 2dip debugger-popup ] error-hook set ] + [ '[ _ ui-error-summary ] error-summary-hook set ] bi tip-of-the-day. nl listener ] with-streams* ; From b1d0066baa92f81bc87eda0e8e26eb6bff02fd6c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 00:27:21 -0500 Subject: [PATCH 71/98] ui.tools.listener: better error summary display --- basis/help/markup/markup.factor | 2 +- basis/io/styles/styles.factor | 2 ++ basis/ui/tools/listener/listener.factor | 17 +++++++++++------ 3 files changed, 14 insertions(+), 7 deletions(-) diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index 8b5edf38c1..f22560a4ce 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -138,7 +138,7 @@ ALIAS: $slot $snippet ! Images : $image ( element -- ) - [ [ "" ] dip first image associate format ] ($span) ; + [ first write-image ] ($span) ; : <$image> ( path -- element ) 1array \ $image prefix ; diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor index 66b5f0458f..c3bf5d2f28 100644 --- a/basis/io/styles/styles.factor +++ b/basis/io/styles/styles.factor @@ -156,3 +156,5 @@ M: input summary ] "" make ; : write-object ( str obj -- ) presented associate format ; + +: write-image ( image -- ) [ "" ] dip image associate format ; diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 249be0b291..3a1c68fa25 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -13,7 +13,7 @@ ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations ui.tools.browser ui.tools.common ui.tools.debugger ui.tools.listener.completion ui.tools.listener.popups -ui.tools.listener.history ui.tools.error-list ; +ui.tools.listener.history ui.tools.error-list ui.images ; FROM: source-files.errors => all-errors ; IN: ui.tools.listener @@ -187,8 +187,11 @@ TUPLE: listener-gadget < tool error-summary output scroller input ; [ >>input ] [ pane new-pane t >>scrolls? >>output ] bi dup listener-streams >>output drop ; +: ( -- gadget ) + COLOR: light-yellow >>interior ; + : init-error-summary ( listener -- listener ) - >>error-summary + >>error-summary dup error-summary>> f track-add ; : ( -- listener ) @@ -363,12 +366,14 @@ interactor "completion" f { { T{ key-down f { C+ } "r" } history-completion-popup } } define-command-map -: ui-error-summary ( listener -- ) +: error-summary. ( listener -- ) error-summary>> [ error-counts keys [ - [ icon>> 1array \ $image prefix " " 2array ] { } map-as + H{ { table-gap { 3 3 } } } [ + [ [ [ icon>> write-image ] with-cell ] each ] with-row + ] tabular-output { "Press " { $command tool "common" show-error-list } " to view errors." } - append print-element + print-element ] unless-empty ] with-pane ; @@ -376,7 +381,7 @@ interactor "completion" f { dup listener-streams [ [ com-browse ] help-hook set [ '[ [ _ input>> ] 2dip debugger-popup ] error-hook set ] - [ '[ _ ui-error-summary ] error-summary-hook set ] bi + [ '[ _ error-summary. ] error-summary-hook set ] bi tip-of-the-day. nl listener ] with-streams* ; From 784f34e49f70b0e00b84321856dddaa989e13ab3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Apr 2009 01:44:25 -0500 Subject: [PATCH 72/98] turn off autouse for sandboxed code --- extra/sandbox/sandbox.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/sandbox/sandbox.factor b/extra/sandbox/sandbox.factor index a9d65ee5ab..097a7c8d8a 100644 --- a/extra/sandbox/sandbox.factor +++ b/extra/sandbox/sandbox.factor @@ -10,7 +10,7 @@ SYMBOL: whitelist : with-sandbox-vocabs ( quot -- ) "sandbox.syntax" load-vocab vocab-words 1vector - use [ call ] with-variable ; inline + use [ auto-use? off call ] with-variable ; inline : parse-sandbox ( lines assoc -- quot ) whitelist [ [ parse-lines ] with-sandbox-vocabs ] with-variable ; From 1a28a5e30def0484375d11fd67416c0bca3c82b5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Apr 2009 02:01:35 -0500 Subject: [PATCH 73/98] accidentally checked in db2 branch. move to unmaintained for now --- {extra => unmaintained}/db2/authors.txt | 0 {extra => unmaintained}/db2/connections/authors.txt | 0 {extra => unmaintained}/db2/connections/connections-tests.factor | 0 {extra => unmaintained}/db2/connections/connections.factor | 0 {extra => unmaintained}/db2/db2-tests.factor | 0 {extra => unmaintained}/db2/db2.factor | 0 {extra => unmaintained}/db2/errors/errors.factor | 0 {extra => unmaintained}/db2/errors/summary.txt | 0 {extra => unmaintained}/db2/fql/authors.txt | 0 {extra => unmaintained}/db2/fql/fql-tests.factor | 0 {extra => unmaintained}/db2/fql/fql.factor | 0 {extra => unmaintained}/db2/introspection/authors.txt | 0 {extra => unmaintained}/db2/introspection/introspection.factor | 0 {extra => unmaintained}/db2/pools/authors.txt | 0 {extra => unmaintained}/db2/pools/pools-tests.factor | 0 {extra => unmaintained}/db2/pools/pools.factor | 0 {extra => unmaintained}/db2/result-sets/authors.txt | 0 {extra => unmaintained}/db2/result-sets/result-sets.factor | 0 {extra => unmaintained}/db2/sqlite/authors.txt | 0 {extra => unmaintained}/db2/sqlite/connections/authors.txt | 0 .../db2/sqlite/connections/connections-tests.factor | 0 {extra => unmaintained}/db2/sqlite/connections/connections.factor | 0 {extra => unmaintained}/db2/sqlite/db/authors.txt | 0 {extra => unmaintained}/db2/sqlite/db/db.factor | 0 {extra => unmaintained}/db2/sqlite/errors/authors.txt | 0 {extra => unmaintained}/db2/sqlite/errors/errors.factor | 0 {extra => unmaintained}/db2/sqlite/ffi/ffi.factor | 0 {extra => unmaintained}/db2/sqlite/introspection/authors.txt | 0 .../db2/sqlite/introspection/introspection-tests.factor | 0 .../db2/sqlite/introspection/introspection.factor | 0 {extra => unmaintained}/db2/sqlite/lib/lib.factor | 0 {extra => unmaintained}/db2/sqlite/result-sets/authors.txt | 0 {extra => unmaintained}/db2/sqlite/result-sets/result-sets.factor | 0 {extra => unmaintained}/db2/sqlite/sqlite.factor | 0 {extra => unmaintained}/db2/sqlite/statements/authors.txt | 0 {extra => unmaintained}/db2/sqlite/statements/statements.factor | 0 {extra => unmaintained}/db2/sqlite/types/authors.txt | 0 {extra => unmaintained}/db2/sqlite/types/types.factor | 0 {extra => unmaintained}/db2/statements/authors.txt | 0 {extra => unmaintained}/db2/statements/statements-tests.factor | 0 {extra => unmaintained}/db2/statements/statements.factor | 0 {extra => unmaintained}/db2/tester/authors.txt | 0 {extra => unmaintained}/db2/tester/tester-tests.factor | 0 {extra => unmaintained}/db2/tester/tester.factor | 0 {extra => unmaintained}/db2/transactions/authors.txt | 0 {extra => unmaintained}/db2/transactions/transactions.factor | 0 {extra => unmaintained}/db2/types/authors.txt | 0 {extra => unmaintained}/db2/types/types.factor | 0 {extra => unmaintained}/db2/utils/authors.txt | 0 {extra => unmaintained}/db2/utils/utils.factor | 0 50 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/db2/authors.txt (100%) rename {extra => unmaintained}/db2/connections/authors.txt (100%) rename {extra => unmaintained}/db2/connections/connections-tests.factor (100%) rename {extra => unmaintained}/db2/connections/connections.factor (100%) rename {extra => unmaintained}/db2/db2-tests.factor (100%) rename {extra => unmaintained}/db2/db2.factor (100%) rename {extra => unmaintained}/db2/errors/errors.factor (100%) rename {extra => unmaintained}/db2/errors/summary.txt (100%) rename {extra => unmaintained}/db2/fql/authors.txt (100%) rename {extra => unmaintained}/db2/fql/fql-tests.factor (100%) rename {extra => unmaintained}/db2/fql/fql.factor (100%) rename {extra => unmaintained}/db2/introspection/authors.txt (100%) rename {extra => unmaintained}/db2/introspection/introspection.factor (100%) rename {extra => unmaintained}/db2/pools/authors.txt (100%) rename {extra => unmaintained}/db2/pools/pools-tests.factor (100%) rename {extra => unmaintained}/db2/pools/pools.factor (100%) rename {extra => unmaintained}/db2/result-sets/authors.txt (100%) rename {extra => unmaintained}/db2/result-sets/result-sets.factor (100%) rename {extra => unmaintained}/db2/sqlite/authors.txt (100%) rename {extra => unmaintained}/db2/sqlite/connections/authors.txt (100%) rename {extra => unmaintained}/db2/sqlite/connections/connections-tests.factor (100%) rename {extra => unmaintained}/db2/sqlite/connections/connections.factor (100%) rename {extra => unmaintained}/db2/sqlite/db/authors.txt (100%) rename {extra => unmaintained}/db2/sqlite/db/db.factor (100%) rename {extra => unmaintained}/db2/sqlite/errors/authors.txt (100%) rename {extra => unmaintained}/db2/sqlite/errors/errors.factor (100%) rename {extra => unmaintained}/db2/sqlite/ffi/ffi.factor (100%) rename {extra => unmaintained}/db2/sqlite/introspection/authors.txt (100%) rename {extra => unmaintained}/db2/sqlite/introspection/introspection-tests.factor (100%) rename {extra => unmaintained}/db2/sqlite/introspection/introspection.factor (100%) rename {extra => unmaintained}/db2/sqlite/lib/lib.factor (100%) rename {extra => unmaintained}/db2/sqlite/result-sets/authors.txt (100%) rename {extra => unmaintained}/db2/sqlite/result-sets/result-sets.factor (100%) rename {extra => unmaintained}/db2/sqlite/sqlite.factor (100%) rename {extra => unmaintained}/db2/sqlite/statements/authors.txt (100%) rename {extra => unmaintained}/db2/sqlite/statements/statements.factor (100%) rename {extra => unmaintained}/db2/sqlite/types/authors.txt (100%) rename {extra => unmaintained}/db2/sqlite/types/types.factor (100%) rename {extra => unmaintained}/db2/statements/authors.txt (100%) rename {extra => unmaintained}/db2/statements/statements-tests.factor (100%) rename {extra => unmaintained}/db2/statements/statements.factor (100%) rename {extra => unmaintained}/db2/tester/authors.txt (100%) rename {extra => unmaintained}/db2/tester/tester-tests.factor (100%) rename {extra => unmaintained}/db2/tester/tester.factor (100%) rename {extra => unmaintained}/db2/transactions/authors.txt (100%) rename {extra => unmaintained}/db2/transactions/transactions.factor (100%) rename {extra => unmaintained}/db2/types/authors.txt (100%) rename {extra => unmaintained}/db2/types/types.factor (100%) rename {extra => unmaintained}/db2/utils/authors.txt (100%) rename {extra => unmaintained}/db2/utils/utils.factor (100%) diff --git a/extra/db2/authors.txt b/unmaintained/db2/authors.txt similarity index 100% rename from extra/db2/authors.txt rename to unmaintained/db2/authors.txt diff --git a/extra/db2/connections/authors.txt b/unmaintained/db2/connections/authors.txt similarity index 100% rename from extra/db2/connections/authors.txt rename to unmaintained/db2/connections/authors.txt diff --git a/extra/db2/connections/connections-tests.factor b/unmaintained/db2/connections/connections-tests.factor similarity index 100% rename from extra/db2/connections/connections-tests.factor rename to unmaintained/db2/connections/connections-tests.factor diff --git a/extra/db2/connections/connections.factor b/unmaintained/db2/connections/connections.factor similarity index 100% rename from extra/db2/connections/connections.factor rename to unmaintained/db2/connections/connections.factor diff --git a/extra/db2/db2-tests.factor b/unmaintained/db2/db2-tests.factor similarity index 100% rename from extra/db2/db2-tests.factor rename to unmaintained/db2/db2-tests.factor diff --git a/extra/db2/db2.factor b/unmaintained/db2/db2.factor similarity index 100% rename from extra/db2/db2.factor rename to unmaintained/db2/db2.factor diff --git a/extra/db2/errors/errors.factor b/unmaintained/db2/errors/errors.factor similarity index 100% rename from extra/db2/errors/errors.factor rename to unmaintained/db2/errors/errors.factor diff --git a/extra/db2/errors/summary.txt b/unmaintained/db2/errors/summary.txt similarity index 100% rename from extra/db2/errors/summary.txt rename to unmaintained/db2/errors/summary.txt diff --git a/extra/db2/fql/authors.txt b/unmaintained/db2/fql/authors.txt similarity index 100% rename from extra/db2/fql/authors.txt rename to unmaintained/db2/fql/authors.txt diff --git a/extra/db2/fql/fql-tests.factor b/unmaintained/db2/fql/fql-tests.factor similarity index 100% rename from extra/db2/fql/fql-tests.factor rename to unmaintained/db2/fql/fql-tests.factor diff --git a/extra/db2/fql/fql.factor b/unmaintained/db2/fql/fql.factor similarity index 100% rename from extra/db2/fql/fql.factor rename to unmaintained/db2/fql/fql.factor diff --git a/extra/db2/introspection/authors.txt b/unmaintained/db2/introspection/authors.txt similarity index 100% rename from extra/db2/introspection/authors.txt rename to unmaintained/db2/introspection/authors.txt diff --git a/extra/db2/introspection/introspection.factor b/unmaintained/db2/introspection/introspection.factor similarity index 100% rename from extra/db2/introspection/introspection.factor rename to unmaintained/db2/introspection/introspection.factor diff --git a/extra/db2/pools/authors.txt b/unmaintained/db2/pools/authors.txt similarity index 100% rename from extra/db2/pools/authors.txt rename to unmaintained/db2/pools/authors.txt diff --git a/extra/db2/pools/pools-tests.factor b/unmaintained/db2/pools/pools-tests.factor similarity index 100% rename from extra/db2/pools/pools-tests.factor rename to unmaintained/db2/pools/pools-tests.factor diff --git a/extra/db2/pools/pools.factor b/unmaintained/db2/pools/pools.factor similarity index 100% rename from extra/db2/pools/pools.factor rename to unmaintained/db2/pools/pools.factor diff --git a/extra/db2/result-sets/authors.txt b/unmaintained/db2/result-sets/authors.txt similarity index 100% rename from extra/db2/result-sets/authors.txt rename to unmaintained/db2/result-sets/authors.txt diff --git a/extra/db2/result-sets/result-sets.factor b/unmaintained/db2/result-sets/result-sets.factor similarity index 100% rename from extra/db2/result-sets/result-sets.factor rename to unmaintained/db2/result-sets/result-sets.factor diff --git a/extra/db2/sqlite/authors.txt b/unmaintained/db2/sqlite/authors.txt similarity index 100% rename from extra/db2/sqlite/authors.txt rename to unmaintained/db2/sqlite/authors.txt diff --git a/extra/db2/sqlite/connections/authors.txt b/unmaintained/db2/sqlite/connections/authors.txt similarity index 100% rename from extra/db2/sqlite/connections/authors.txt rename to unmaintained/db2/sqlite/connections/authors.txt diff --git a/extra/db2/sqlite/connections/connections-tests.factor b/unmaintained/db2/sqlite/connections/connections-tests.factor similarity index 100% rename from extra/db2/sqlite/connections/connections-tests.factor rename to unmaintained/db2/sqlite/connections/connections-tests.factor diff --git a/extra/db2/sqlite/connections/connections.factor b/unmaintained/db2/sqlite/connections/connections.factor similarity index 100% rename from extra/db2/sqlite/connections/connections.factor rename to unmaintained/db2/sqlite/connections/connections.factor diff --git a/extra/db2/sqlite/db/authors.txt b/unmaintained/db2/sqlite/db/authors.txt similarity index 100% rename from extra/db2/sqlite/db/authors.txt rename to unmaintained/db2/sqlite/db/authors.txt diff --git a/extra/db2/sqlite/db/db.factor b/unmaintained/db2/sqlite/db/db.factor similarity index 100% rename from extra/db2/sqlite/db/db.factor rename to unmaintained/db2/sqlite/db/db.factor diff --git a/extra/db2/sqlite/errors/authors.txt b/unmaintained/db2/sqlite/errors/authors.txt similarity index 100% rename from extra/db2/sqlite/errors/authors.txt rename to unmaintained/db2/sqlite/errors/authors.txt diff --git a/extra/db2/sqlite/errors/errors.factor b/unmaintained/db2/sqlite/errors/errors.factor similarity index 100% rename from extra/db2/sqlite/errors/errors.factor rename to unmaintained/db2/sqlite/errors/errors.factor diff --git a/extra/db2/sqlite/ffi/ffi.factor b/unmaintained/db2/sqlite/ffi/ffi.factor similarity index 100% rename from extra/db2/sqlite/ffi/ffi.factor rename to unmaintained/db2/sqlite/ffi/ffi.factor diff --git a/extra/db2/sqlite/introspection/authors.txt b/unmaintained/db2/sqlite/introspection/authors.txt similarity index 100% rename from extra/db2/sqlite/introspection/authors.txt rename to unmaintained/db2/sqlite/introspection/authors.txt diff --git a/extra/db2/sqlite/introspection/introspection-tests.factor b/unmaintained/db2/sqlite/introspection/introspection-tests.factor similarity index 100% rename from extra/db2/sqlite/introspection/introspection-tests.factor rename to unmaintained/db2/sqlite/introspection/introspection-tests.factor diff --git a/extra/db2/sqlite/introspection/introspection.factor b/unmaintained/db2/sqlite/introspection/introspection.factor similarity index 100% rename from extra/db2/sqlite/introspection/introspection.factor rename to unmaintained/db2/sqlite/introspection/introspection.factor diff --git a/extra/db2/sqlite/lib/lib.factor b/unmaintained/db2/sqlite/lib/lib.factor similarity index 100% rename from extra/db2/sqlite/lib/lib.factor rename to unmaintained/db2/sqlite/lib/lib.factor diff --git a/extra/db2/sqlite/result-sets/authors.txt b/unmaintained/db2/sqlite/result-sets/authors.txt similarity index 100% rename from extra/db2/sqlite/result-sets/authors.txt rename to unmaintained/db2/sqlite/result-sets/authors.txt diff --git a/extra/db2/sqlite/result-sets/result-sets.factor b/unmaintained/db2/sqlite/result-sets/result-sets.factor similarity index 100% rename from extra/db2/sqlite/result-sets/result-sets.factor rename to unmaintained/db2/sqlite/result-sets/result-sets.factor diff --git a/extra/db2/sqlite/sqlite.factor b/unmaintained/db2/sqlite/sqlite.factor similarity index 100% rename from extra/db2/sqlite/sqlite.factor rename to unmaintained/db2/sqlite/sqlite.factor diff --git a/extra/db2/sqlite/statements/authors.txt b/unmaintained/db2/sqlite/statements/authors.txt similarity index 100% rename from extra/db2/sqlite/statements/authors.txt rename to unmaintained/db2/sqlite/statements/authors.txt diff --git a/extra/db2/sqlite/statements/statements.factor b/unmaintained/db2/sqlite/statements/statements.factor similarity index 100% rename from extra/db2/sqlite/statements/statements.factor rename to unmaintained/db2/sqlite/statements/statements.factor diff --git a/extra/db2/sqlite/types/authors.txt b/unmaintained/db2/sqlite/types/authors.txt similarity index 100% rename from extra/db2/sqlite/types/authors.txt rename to unmaintained/db2/sqlite/types/authors.txt diff --git a/extra/db2/sqlite/types/types.factor b/unmaintained/db2/sqlite/types/types.factor similarity index 100% rename from extra/db2/sqlite/types/types.factor rename to unmaintained/db2/sqlite/types/types.factor diff --git a/extra/db2/statements/authors.txt b/unmaintained/db2/statements/authors.txt similarity index 100% rename from extra/db2/statements/authors.txt rename to unmaintained/db2/statements/authors.txt diff --git a/extra/db2/statements/statements-tests.factor b/unmaintained/db2/statements/statements-tests.factor similarity index 100% rename from extra/db2/statements/statements-tests.factor rename to unmaintained/db2/statements/statements-tests.factor diff --git a/extra/db2/statements/statements.factor b/unmaintained/db2/statements/statements.factor similarity index 100% rename from extra/db2/statements/statements.factor rename to unmaintained/db2/statements/statements.factor diff --git a/extra/db2/tester/authors.txt b/unmaintained/db2/tester/authors.txt similarity index 100% rename from extra/db2/tester/authors.txt rename to unmaintained/db2/tester/authors.txt diff --git a/extra/db2/tester/tester-tests.factor b/unmaintained/db2/tester/tester-tests.factor similarity index 100% rename from extra/db2/tester/tester-tests.factor rename to unmaintained/db2/tester/tester-tests.factor diff --git a/extra/db2/tester/tester.factor b/unmaintained/db2/tester/tester.factor similarity index 100% rename from extra/db2/tester/tester.factor rename to unmaintained/db2/tester/tester.factor diff --git a/extra/db2/transactions/authors.txt b/unmaintained/db2/transactions/authors.txt similarity index 100% rename from extra/db2/transactions/authors.txt rename to unmaintained/db2/transactions/authors.txt diff --git a/extra/db2/transactions/transactions.factor b/unmaintained/db2/transactions/transactions.factor similarity index 100% rename from extra/db2/transactions/transactions.factor rename to unmaintained/db2/transactions/transactions.factor diff --git a/extra/db2/types/authors.txt b/unmaintained/db2/types/authors.txt similarity index 100% rename from extra/db2/types/authors.txt rename to unmaintained/db2/types/authors.txt diff --git a/extra/db2/types/types.factor b/unmaintained/db2/types/types.factor similarity index 100% rename from extra/db2/types/types.factor rename to unmaintained/db2/types/types.factor diff --git a/extra/db2/utils/authors.txt b/unmaintained/db2/utils/authors.txt similarity index 100% rename from extra/db2/utils/authors.txt rename to unmaintained/db2/utils/authors.txt diff --git a/extra/db2/utils/utils.factor b/unmaintained/db2/utils/utils.factor similarity index 100% rename from extra/db2/utils/utils.factor rename to unmaintained/db2/utils/utils.factor From 11be11605f48c90fc3fac66ed45b6c6888d98471 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Apr 2009 02:15:01 -0500 Subject: [PATCH 74/98] remove db2 from unmaintained --- unmaintained/db2/authors.txt | 1 - unmaintained/db2/connections/authors.txt | 1 - .../db2/connections/connections-tests.factor | 8 - .../db2/connections/connections.factor | 20 --- unmaintained/db2/db2-tests.factor | 5 - unmaintained/db2/db2.factor | 78 ---------- unmaintained/db2/errors/errors.factor | 42 ------ unmaintained/db2/errors/summary.txt | 1 - unmaintained/db2/fql/authors.txt | 1 - unmaintained/db2/fql/fql-tests.factor | 72 --------- unmaintained/db2/fql/fql.factor | 116 -------------- unmaintained/db2/introspection/authors.txt | 1 - .../db2/introspection/introspection.factor | 34 ----- unmaintained/db2/pools/authors.txt | 1 - unmaintained/db2/pools/pools-tests.factor | 23 --- unmaintained/db2/pools/pools.factor | 20 --- unmaintained/db2/result-sets/authors.txt | 1 - .../db2/result-sets/result-sets.factor | 33 ---- unmaintained/db2/sqlite/authors.txt | 1 - .../db2/sqlite/connections/authors.txt | 1 - .../connections/connections-tests.factor | 4 - .../db2/sqlite/connections/connections.factor | 17 --- unmaintained/db2/sqlite/db/authors.txt | 1 - unmaintained/db2/sqlite/db/db.factor | 12 -- unmaintained/db2/sqlite/errors/authors.txt | 1 - unmaintained/db2/sqlite/errors/errors.factor | 35 ----- unmaintained/db2/sqlite/ffi/ffi.factor | 142 ------------------ .../db2/sqlite/introspection/authors.txt | 1 - .../introspection/introspection-tests.factor | 38 ----- .../sqlite/introspection/introspection.factor | 16 -- unmaintained/db2/sqlite/lib/lib.factor | 110 -------------- .../db2/sqlite/result-sets/authors.txt | 1 - .../db2/sqlite/result-sets/result-sets.factor | 30 ---- unmaintained/db2/sqlite/sqlite.factor | 12 -- .../db2/sqlite/statements/authors.txt | 1 - .../db2/sqlite/statements/statements.factor | 19 --- unmaintained/db2/sqlite/types/authors.txt | 1 - unmaintained/db2/sqlite/types/types.factor | 104 ------------- unmaintained/db2/statements/authors.txt | 1 - .../db2/statements/statements-tests.factor | 73 --------- unmaintained/db2/statements/statements.factor | 53 ------- unmaintained/db2/tester/authors.txt | 2 - unmaintained/db2/tester/tester-tests.factor | 7 - unmaintained/db2/tester/tester.factor | 96 ------------ unmaintained/db2/transactions/authors.txt | 1 - .../db2/transactions/transactions.factor | 26 ---- unmaintained/db2/types/authors.txt | 1 - unmaintained/db2/types/types.factor | 17 --- unmaintained/db2/utils/authors.txt | 1 - unmaintained/db2/utils/utils.factor | 32 ---- 50 files changed, 1315 deletions(-) delete mode 100644 unmaintained/db2/authors.txt delete mode 100644 unmaintained/db2/connections/authors.txt delete mode 100644 unmaintained/db2/connections/connections-tests.factor delete mode 100644 unmaintained/db2/connections/connections.factor delete mode 100644 unmaintained/db2/db2-tests.factor delete mode 100644 unmaintained/db2/db2.factor delete mode 100644 unmaintained/db2/errors/errors.factor delete mode 100644 unmaintained/db2/errors/summary.txt delete mode 100644 unmaintained/db2/fql/authors.txt delete mode 100644 unmaintained/db2/fql/fql-tests.factor delete mode 100644 unmaintained/db2/fql/fql.factor delete mode 100644 unmaintained/db2/introspection/authors.txt delete mode 100644 unmaintained/db2/introspection/introspection.factor delete mode 100644 unmaintained/db2/pools/authors.txt delete mode 100644 unmaintained/db2/pools/pools-tests.factor delete mode 100644 unmaintained/db2/pools/pools.factor delete mode 100644 unmaintained/db2/result-sets/authors.txt delete mode 100644 unmaintained/db2/result-sets/result-sets.factor delete mode 100644 unmaintained/db2/sqlite/authors.txt delete mode 100644 unmaintained/db2/sqlite/connections/authors.txt delete mode 100644 unmaintained/db2/sqlite/connections/connections-tests.factor delete mode 100644 unmaintained/db2/sqlite/connections/connections.factor delete mode 100644 unmaintained/db2/sqlite/db/authors.txt delete mode 100644 unmaintained/db2/sqlite/db/db.factor delete mode 100644 unmaintained/db2/sqlite/errors/authors.txt delete mode 100644 unmaintained/db2/sqlite/errors/errors.factor delete mode 100644 unmaintained/db2/sqlite/ffi/ffi.factor delete mode 100644 unmaintained/db2/sqlite/introspection/authors.txt delete mode 100644 unmaintained/db2/sqlite/introspection/introspection-tests.factor delete mode 100644 unmaintained/db2/sqlite/introspection/introspection.factor delete mode 100644 unmaintained/db2/sqlite/lib/lib.factor delete mode 100644 unmaintained/db2/sqlite/result-sets/authors.txt delete mode 100644 unmaintained/db2/sqlite/result-sets/result-sets.factor delete mode 100644 unmaintained/db2/sqlite/sqlite.factor delete mode 100644 unmaintained/db2/sqlite/statements/authors.txt delete mode 100644 unmaintained/db2/sqlite/statements/statements.factor delete mode 100644 unmaintained/db2/sqlite/types/authors.txt delete mode 100644 unmaintained/db2/sqlite/types/types.factor delete mode 100644 unmaintained/db2/statements/authors.txt delete mode 100644 unmaintained/db2/statements/statements-tests.factor delete mode 100644 unmaintained/db2/statements/statements.factor delete mode 100644 unmaintained/db2/tester/authors.txt delete mode 100644 unmaintained/db2/tester/tester-tests.factor delete mode 100644 unmaintained/db2/tester/tester.factor delete mode 100644 unmaintained/db2/transactions/authors.txt delete mode 100644 unmaintained/db2/transactions/transactions.factor delete mode 100644 unmaintained/db2/types/authors.txt delete mode 100644 unmaintained/db2/types/types.factor delete mode 100644 unmaintained/db2/utils/authors.txt delete mode 100644 unmaintained/db2/utils/utils.factor diff --git a/unmaintained/db2/authors.txt b/unmaintained/db2/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/connections/authors.txt b/unmaintained/db2/connections/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/connections/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/connections/connections-tests.factor b/unmaintained/db2/connections/connections-tests.factor deleted file mode 100644 index f96a201bf6..0000000000 --- a/unmaintained/db2/connections/connections-tests.factor +++ /dev/null @@ -1,8 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test db2.connections db2.tester ; -IN: db2.connections.tests - -! Tests connection - -{ 1 0 } [ [ ] with-db ] must-infer-as diff --git a/unmaintained/db2/connections/connections.factor b/unmaintained/db2/connections/connections.factor deleted file mode 100644 index 7957cb918a..0000000000 --- a/unmaintained/db2/connections/connections.factor +++ /dev/null @@ -1,20 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors destructors fry kernel namespaces ; -IN: db2.connections - -TUPLE: db-connection handle ; - -: new-db-connection ( handle class -- db-connection ) - new - swap >>handle ; inline - -GENERIC: db-open ( db -- db-connection ) -GENERIC: db-close ( handle -- ) - -M: db-connection dispose ( db-connection -- ) - [ db-close ] [ f >>handle drop ] bi ; - -: with-db ( db quot -- ) - [ db-open db-connection over ] dip - '[ _ [ drop @ ] with-disposal ] with-variable ; inline diff --git a/unmaintained/db2/db2-tests.factor b/unmaintained/db2/db2-tests.factor deleted file mode 100644 index 30ee7b3581..0000000000 --- a/unmaintained/db2/db2-tests.factor +++ /dev/null @@ -1,5 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test db2 kernel ; -IN: db2.tests - diff --git a/unmaintained/db2/db2.factor b/unmaintained/db2/db2.factor deleted file mode 100644 index b14ee969be..0000000000 --- a/unmaintained/db2/db2.factor +++ /dev/null @@ -1,78 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors continuations db2.result-sets db2.sqlite.lib -db2.sqlite.result-sets db2.sqlite.statements db2.statements -destructors fry kernel math namespaces sequences strings -db2.sqlite.types ; -IN: db2 - -ERROR: no-in-types statement ; -ERROR: no-out-types statement ; - -: guard-in ( statement -- statement ) - dup in>> [ no-in-types ] unless ; - -: guard-out ( statement -- statement ) - dup out>> [ no-out-types ] unless ; - -GENERIC: sql-command ( object -- ) -GENERIC: sql-query ( object -- sequence ) -GENERIC: sql-bind-command ( object -- ) -GENERIC: sql-bind-query ( object -- sequence ) -GENERIC: sql-bind-typed-command ( object -- ) -GENERIC: sql-bind-typed-query ( object -- sequence ) - -M: string sql-command ( string -- ) - f f sql-command ; - -M: string sql-query ( string -- sequence ) - f f sql-query ; - -M: statement sql-command ( statement -- ) - [ execute-statement ] with-disposal ; - -M: statement sql-query ( statement -- sequence ) - [ statement>result-sequence ] with-disposal ; - -M: statement sql-bind-command ( statement -- ) - [ - guard-in - prepare-statement - [ bind-sequence ] [ statement>result-set drop ] bi - ] with-disposal ; - -M: statement sql-bind-query ( statement -- sequence ) - [ - guard-in - prepare-statement - [ bind-sequence ] [ statement>result-sequence ] bi - ] with-disposal ; - -M: statement sql-bind-typed-command ( statement -- ) - [ - guard-in - prepare-statement - [ bind-typed-sequence ] [ statement>result-set drop ] bi - ] with-disposal ; - -M: statement sql-bind-typed-query ( statement -- sequence ) - [ - guard-in - guard-out - prepare-statement - [ bind-typed-sequence ] [ statement>typed-result-sequence ] bi - ] with-disposal ; - -M: sequence sql-command [ sql-command ] each ; -M: sequence sql-query [ sql-query ] map ; -M: sequence sql-bind-command [ sql-bind-command ] each ; -M: sequence sql-bind-query [ sql-bind-query ] map ; -M: sequence sql-bind-typed-command [ sql-bind-typed-command ] each ; -M: sequence sql-bind-typed-query [ sql-bind-typed-query ] map ; - -M: integer sql-command throw ; -M: integer sql-query throw ; -M: integer sql-bind-command throw ; -M: integer sql-bind-query throw ; -M: integer sql-bind-typed-command throw ; -M: integer sql-bind-typed-query throw ; diff --git a/unmaintained/db2/errors/errors.factor b/unmaintained/db2/errors/errors.factor deleted file mode 100644 index 45353f6fb9..0000000000 --- a/unmaintained/db2/errors/errors.factor +++ /dev/null @@ -1,42 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel continuations fry words constructors -db2.connections ; -IN: db2.errors - -ERROR: db-error ; -ERROR: sql-error location ; -HOOK: parse-sql-error db-connection ( error -- error' ) - -ERROR: sql-unknown-error < sql-error message ; -CONSTRUCTOR: sql-unknown-error ( message -- error ) ; - -ERROR: sql-table-exists < sql-error table ; -CONSTRUCTOR: sql-table-exists ( table -- error ) ; - -ERROR: sql-table-missing < sql-error table ; -CONSTRUCTOR: sql-table-missing ( table -- error ) ; - -ERROR: sql-syntax-error < sql-error message ; -CONSTRUCTOR: sql-syntax-error ( message -- error ) ; - -ERROR: sql-function-exists < sql-error message ; -CONSTRUCTOR: sql-function-exists ( message -- error ) ; - -ERROR: sql-function-missing < sql-error message ; -CONSTRUCTOR: sql-function-missing ( message -- error ) ; - -: ignore-error ( quot word -- ) - '[ dup _ execute [ drop ] [ rethrow ] if ] recover ; inline - -: ignore-table-exists ( quot -- ) - \ sql-table-exists? ignore-error ; inline - -: ignore-table-missing ( quot -- ) - \ sql-table-missing? ignore-error ; inline - -: ignore-function-exists ( quot -- ) - \ sql-function-exists? ignore-error ; inline - -: ignore-function-missing ( quot -- ) - \ sql-function-missing? ignore-error ; inline diff --git a/unmaintained/db2/errors/summary.txt b/unmaintained/db2/errors/summary.txt deleted file mode 100644 index 1cd102173f..0000000000 --- a/unmaintained/db2/errors/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Errors thrown by database library diff --git a/unmaintained/db2/fql/authors.txt b/unmaintained/db2/fql/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/fql/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/fql/fql-tests.factor b/unmaintained/db2/fql/fql-tests.factor deleted file mode 100644 index 84698c09c2..0000000000 --- a/unmaintained/db2/fql/fql-tests.factor +++ /dev/null @@ -1,72 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors db2 db2.statements.tests db2.tester -kernel tools.test db2.fql ; -IN: db2.fql.tests - -: test-fql ( -- ) - create-computer-table - - [ "insert into computer (name, os) values (?, ?);" ] - [ - "computer" { "name" "os" } { "lol" "os2" } expand-fql - sql>> - ] unit-test - - [ "select name, os from computer" ] - [ - select new - { "name" "os" } >>names - "computer" >>from - expand-fql sql>> - ] unit-test - - [ "select name, os from computer group by os order by lol offset 100 limit 3" ] - [ - select new - { "name" "os" } >>names - "computer" >>from - "os" >>group-by - "lol" >>order-by - 100 >>offset - 3 >>limit - expand-fql sql>> - ] unit-test - - [ - "select name, os from computer where (hmm > 1 or foo is NULL) group by os order by lol offset 100 limit 3" - ] [ - select new - { "name" "os" } >>names - "computer" >>from - T{ or f { "hmm > 1" "foo is NULL" } } >>where - "os" >>group-by - "lol" >>order-by - 100 >>offset - 3 >>limit - expand-fql sql>> - ] unit-test - - [ "delete from computer order by omg limit 3" ] - [ - delete new - "computer" >>tables - "omg" >>order-by - 3 >>limit - expand-fql sql>> - ] unit-test - - [ "update computer set name = oscar order by omg limit 3" ] - [ - update new - "computer" >>tables - "name" >>keys - "oscar" >>values - "omg" >>order-by - 3 >>limit - expand-fql sql>> - ] unit-test - - ; - -[ test-fql ] test-dbs diff --git a/unmaintained/db2/fql/fql.factor b/unmaintained/db2/fql/fql.factor deleted file mode 100644 index 0896899b01..0000000000 --- a/unmaintained/db2/fql/fql.factor +++ /dev/null @@ -1,116 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators constructors db2 -db2.private db2.sqlite.lib db2.statements db2.utils destructors -kernel make math.parser sequences strings assocs db2.utils ; -IN: db2.fql - -GENERIC: expand-fql* ( object -- sequence/statement ) -GENERIC: normalize-fql ( object -- sequence/statement ) - -! M: object normalize-fql ; - -TUPLE: insert into names values ; -CONSTRUCTOR: insert ( into names values -- obj ) ; -M: insert normalize-fql ( insert -- insert ) - [ ??1array ] change-names ; - -TUPLE: update tables keys values where order-by limit ; -CONSTRUCTOR: update ( tables keys values where -- obj ) ; -M: update normalize-fql ( insert -- insert ) - [ ??1array ] change-tables - [ ??1array ] change-keys - [ ??1array ] change-values - [ ??1array ] change-order-by ; - -TUPLE: delete tables where order-by limit ; -CONSTRUCTOR: delete ( tables keys values where -- obj ) ; -M: delete normalize-fql ( insert -- insert ) - [ ??1array ] change-tables - [ ??1array ] change-order-by ; - -TUPLE: select names from where group-by order-by offset limit ; -CONSTRUCTOR: select ( names from -- obj ) ; -M: select normalize-fql ( select -- select ) - [ ??1array ] change-names - [ ??1array ] change-from - [ ??1array ] change-group-by - [ ??1array ] change-order-by ; - -! TUPLE: where sequence ; -! M: where normalize-fql ( where -- where ) - ! [ ??1array ] change-sequence ; - -TUPLE: and sequence ; - -TUPLE: or sequence ; - -: expand-fql ( object1 -- object2 ) normalize-fql expand-fql* ; - -M: or expand-fql* ( obj -- string ) - [ - sequence>> "(" % - [ " or " % ] [ expand-fql* % ] interleave - ")" % - ] "" make ; - -M: and expand-fql* ( obj -- string ) - [ - sequence>> "(" % - [ " and " % ] [ expand-fql* % ] interleave - ")" % - ] "" make ; - -M: string expand-fql* ( string -- string ) ; - -M: insert expand-fql* - [ statement new ] dip - [ - { - [ "insert into " % into>> % ] - [ " (" % names>> ", " join % ")" % ] - [ " values (" % values>> length "?" ", " join % ");" % ] - [ values>> >>in ] - } cleave - ] "" make >>sql ; - -M: update expand-fql* - [ statement new ] dip - [ - { - [ "update " % tables>> ", " join % ] - [ - " set " % [ keys>> ] [ values>> ] bi - zip [ ", " % ] [ first2 [ % ] dip " = " % % ] interleave - ] - ! [ " " % from>> ", " join % ] - [ where>> [ " where " % expand-fql* % ] when* ] - [ order-by>> [ " order by " % ", " join % ] when* ] - [ limit>> [ " limit " % # ] when* ] - } cleave - ] "" make >>sql ; - -M: delete expand-fql* - [ statement new ] dip - [ - { - [ "delete from " % tables>> ", " join % ] - [ where>> [ " where " % expand-fql* % ] when* ] - [ order-by>> [ " order by " % ", " join % ] when* ] - [ limit>> [ " limit " % # ] when* ] - } cleave - ] "" make >>sql ; - -M: select expand-fql* - [ statement new ] dip - [ - { - [ "select " % names>> ", " join % ] - [ " from " % from>> ", " join % ] - [ where>> [ " where " % expand-fql* % ] when* ] - [ group-by>> [ " group by " % ", " join % ] when* ] - [ order-by>> [ " order by " % ", " join % ] when* ] - [ offset>> [ " offset " % # ] when* ] - [ limit>> [ " limit " % # ] when* ] - } cleave - ] "" make >>sql ; diff --git a/unmaintained/db2/introspection/authors.txt b/unmaintained/db2/introspection/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/introspection/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/introspection/introspection.factor b/unmaintained/db2/introspection/introspection.factor deleted file mode 100644 index 8ab08876aa..0000000000 --- a/unmaintained/db2/introspection/introspection.factor +++ /dev/null @@ -1,34 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: combinators constructors db2.connections -db2.sqlite.types kernel sequence-parser sequences splitting ; -IN: db2.introspection - -TUPLE: table-schema table columns ; -CONSTRUCTOR: table-schema ( table columns -- table-schema ) ; - -TUPLE: column name type modifiers ; -CONSTRUCTOR: column ( name type modifiers -- column ) ; - -HOOK: query-table-schema* db-connection ( name -- table-schema ) -HOOK: parse-create-statement db-connection ( name -- table-schema ) - -: parse-column ( string -- column ) - skip-whitespace - [ " " take-until-sequence ] - [ take-token sqlite-type>fql-type ] - [ take-rest ] tri ; - -: parse-columns ( string -- seq ) - "," split [ parse-column ] map ; - -M: object parse-create-statement ( string -- table-schema ) - { - [ "CREATE TABLE " take-sequence* ] - [ "(" take-until-sequence ] - [ "(" take-sequence* ] - [ take-rest [ CHAR: ) = ] trim-tail parse-columns ] - } cleave ; - -: query-table-schema ( name -- table-schema ) - query-table-schema* [ parse-create-statement ] map ; diff --git a/unmaintained/db2/pools/authors.txt b/unmaintained/db2/pools/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/unmaintained/db2/pools/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/unmaintained/db2/pools/pools-tests.factor b/unmaintained/db2/pools/pools-tests.factor deleted file mode 100644 index d61b745b03..0000000000 --- a/unmaintained/db2/pools/pools-tests.factor +++ /dev/null @@ -1,23 +0,0 @@ -USING: accessors continuations db2.pools db2.sqlite -db2.sqlite.connections destructors io.directories io.files -io.files.temp kernel math namespaces tools.test -db2.sqlite.connections ; -IN: db2.pools.tests - -\ must-infer - -{ 1 0 } [ [ ] with-db-pool ] must-infer-as - -{ 1 0 } [ [ ] with-pooled-db ] must-infer-as - -! Test behavior after image save/load - -[ "pool-test.db" temp-file delete-file ] ignore-errors - -[ ] [ "pool-test.db" temp-file "pool" set ] unit-test - -[ ] [ "pool" get expired>> t >>expired drop ] unit-test - -[ ] [ 1000 [ "pool" get [ ] with-pooled-db ] times ] unit-test - -[ ] [ "pool" get dispose ] unit-test diff --git a/unmaintained/db2/pools/pools.factor b/unmaintained/db2/pools/pools.factor deleted file mode 100644 index 2b1aa2f0bf..0000000000 --- a/unmaintained/db2/pools/pools.factor +++ /dev/null @@ -1,20 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors db2.connections fry io.pools kernel -namespaces ; -IN: db2.pools - -TUPLE: db-pool < pool db ; - -: ( db -- pool ) - db-pool - swap >>db ; - -: with-db-pool ( db quot -- ) - [ ] dip with-pool ; inline - -M: db-pool make-connection ( pool -- ) - db>> db-open ; - -: with-pooled-db ( pool quot -- ) - '[ db-connection _ with-variable ] with-pooled-connection ; inline diff --git a/unmaintained/db2/result-sets/authors.txt b/unmaintained/db2/result-sets/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/result-sets/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/result-sets/result-sets.factor b/unmaintained/db2/result-sets/result-sets.factor deleted file mode 100644 index 499808930a..0000000000 --- a/unmaintained/db2/result-sets/result-sets.factor +++ /dev/null @@ -1,33 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences combinators fry ; -IN: db2.result-sets - -TUPLE: result-set sql in out handle n max ; - -GENERIC: #rows ( result-set -- n ) -GENERIC: #columns ( result-set -- n ) -GENERIC: advance-row ( result-set -- ) -GENERIC: more-rows? ( result-set -- ? ) -GENERIC# column 1 ( result-set column -- obj ) -GENERIC# column-typed 2 ( result-set column type -- sql ) - -: init-result-set ( result-set -- result-set ) - dup #rows >>max - 0 >>n ; - -: new-result-set ( query class -- result-set ) - new - swap { - [ handle>> >>handle ] - [ sql>> >>sql ] - [ in>> >>in ] - [ out>> >>out ] - } cleave ; - -: sql-row ( result-set -- seq ) - dup #columns [ column ] with map ; - -: sql-row-typed ( result-set -- seq ) - [ #columns ] [ out>> ] [ ] tri - '[ [ _ ] 2dip column-typed ] 2map ; diff --git a/unmaintained/db2/sqlite/authors.txt b/unmaintained/db2/sqlite/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/sqlite/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/sqlite/connections/authors.txt b/unmaintained/db2/sqlite/connections/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/sqlite/connections/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/sqlite/connections/connections-tests.factor b/unmaintained/db2/sqlite/connections/connections-tests.factor deleted file mode 100644 index ed80810508..0000000000 --- a/unmaintained/db2/sqlite/connections/connections-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test db2.sqlite.connections ; -IN: db2.sqlite.connections.tests diff --git a/unmaintained/db2/sqlite/connections/connections.factor b/unmaintained/db2/sqlite/connections/connections.factor deleted file mode 100644 index ae96e58d28..0000000000 --- a/unmaintained/db2/sqlite/connections/connections.factor +++ /dev/null @@ -1,17 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators db2.connections db2.sqlite -db2.sqlite.errors db2.sqlite.lib kernel db2.errors ; -IN: db2.sqlite.connections - -M: sqlite-db db-open ( db -- db-connection ) - path>> sqlite-open ; - -M: sqlite-db-connection db-close ( db-connection -- ) - handle>> sqlite-close ; - -M: sqlite-db-connection parse-sql-error ( error -- error' ) - dup n>> { - { 1 [ string>> parse-sqlite-sql-error ] } - [ drop ] - } case ; diff --git a/unmaintained/db2/sqlite/db/authors.txt b/unmaintained/db2/sqlite/db/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/sqlite/db/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/sqlite/db/db.factor b/unmaintained/db2/sqlite/db/db.factor deleted file mode 100644 index d5d580cb1a..0000000000 --- a/unmaintained/db2/sqlite/db/db.factor +++ /dev/null @@ -1,12 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors ; -IN: db2.sqlite.db - -TUPLE: sqlite-db path ; - -: ( path -- sqlite-db ) - sqlite-db new - swap >>path ; - - diff --git a/unmaintained/db2/sqlite/errors/authors.txt b/unmaintained/db2/sqlite/errors/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/sqlite/errors/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/sqlite/errors/errors.factor b/unmaintained/db2/sqlite/errors/errors.factor deleted file mode 100644 index 61e70f210d..0000000000 --- a/unmaintained/db2/sqlite/errors/errors.factor +++ /dev/null @@ -1,35 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators db2.connections db2.errors -db2.sqlite.ffi kernel locals namespaces peg.ebnf sequences -strings ; -IN: db2.sqlite.errors - -ERROR: sqlite-error < db-error n string ; -ERROR: sqlite-sql-error < sql-error n string ; - -: sqlite-statement-error ( -- * ) - SQLITE_ERROR - db-connection get handle>> sqlite3_errmsg sqlite-sql-error ; - -TUPLE: unparsed-sqlite-error error ; -C: unparsed-sqlite-error - -EBNF: parse-sqlite-sql-error - -TableMessage = " already exists" -SyntaxError = ": syntax error" - -SqliteError = - "table " (!(TableMessage).)+:table TableMessage:message - => [[ table >string ]] - | "near " (!(SyntaxError).)+:syntax SyntaxError:message - => [[ syntax >string ]] - | "no such table: " .+:table - => [[ table >string ]] - | .*:error - => [[ error >string ]] -;EBNF - -: throw-sqlite-error ( n -- * ) - dup sqlite-error-messages nth sqlite-error ; diff --git a/unmaintained/db2/sqlite/ffi/ffi.factor b/unmaintained/db2/sqlite/ffi/ffi.factor deleted file mode 100644 index 2594978ddf..0000000000 --- a/unmaintained/db2/sqlite/ffi/ffi.factor +++ /dev/null @@ -1,142 +0,0 @@ -! Copyright (C) 2005 Chris Double, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -! Not all functions have been wrapped. -USING: alien alien.libraries alien.syntax combinators system ; -IN: db2.sqlite.ffi - -<< "sqlite" { - { [ os winnt? ] [ "sqlite3.dll" ] } - { [ os macosx? ] [ "/usr/lib/libsqlite3.dylib" ] } - { [ os unix? ] [ "libsqlite3.so" ] } - } cond "cdecl" add-library >> - -LIBRARY: sqlite - -! Return values from sqlite functions -CONSTANT: SQLITE_OK 0 ! Successful result -CONSTANT: SQLITE_ERROR 1 ! SQL error or missing database -CONSTANT: SQLITE_INTERNAL 2 ! An internal logic error in SQLite -CONSTANT: SQLITE_PERM 3 ! Access permission denied -CONSTANT: SQLITE_ABORT 4 ! Callback routine requested an abort -CONSTANT: SQLITE_BUSY 5 ! The database file is locked -CONSTANT: SQLITE_LOCKED 6 ! A table in the database is locked -CONSTANT: SQLITE_NOMEM 7 ! A malloc() failed -CONSTANT: SQLITE_READONLY 8 ! Attempt to write a readonly database -CONSTANT: SQLITE_INTERRUPT 9 ! Operation terminated by sqlite_interrupt() -CONSTANT: SQLITE_IOERR 10 ! Some kind of disk I/O error occurred -CONSTANT: SQLITE_CORRUPT 11 ! The database disk image is malformed -CONSTANT: SQLITE_NOTFOUND 12 ! (Internal Only) Table or record not found -CONSTANT: SQLITE_FULL 13 ! Insertion failed because database is full -CONSTANT: SQLITE_CANTOPEN 14 ! Unable to open the database file -CONSTANT: SQLITE_PROTOCOL 15 ! Database lock protocol error -CONSTANT: SQLITE_EMPTY 16 ! (Internal Only) Database table is empty -CONSTANT: SQLITE_SCHEMA 17 ! The database schema changed -CONSTANT: SQLITE_TOOBIG 18 ! Too much data for one row of a table -CONSTANT: SQLITE_CONSTRAINT 19 ! Abort due to contraint violation -CONSTANT: SQLITE_MISMATCH 20 ! Data type mismatch -CONSTANT: SQLITE_MISUSE 21 ! Library used incorrectly -CONSTANT: SQLITE_NOLFS 22 ! Uses OS features not supported on host -CONSTANT: SQLITE_AUTH 23 ! Authorization denied -CONSTANT: SQLITE_FORMAT 24 ! Auxiliary database format error -CONSTANT: SQLITE_RANGE 25 ! 2nd parameter to sqlite3_bind out of range -CONSTANT: SQLITE_NOTADB 26 ! File opened that is not a database file - -CONSTANT: sqlite-error-messages -{ - "Successful result" - "SQL error or missing database" - "An internal logic error in SQLite" - "Access permission denied" - "Callback routine requested an abort" - "The database file is locked" - "A table in the database is locked" - "A malloc() failed" - "Attempt to write a readonly database" - "Operation terminated by sqlite_interrupt()" - "Some kind of disk I/O error occurred" - "The database disk image is malformed" - "(Internal Only) Table or record not found" - "Insertion failed because database is full" - "Unable to open the database file" - "Database lock protocol error" - "(Internal Only) Database table is empty" - "The database schema changed" - "Too much data for one row of a table" - "Abort due to contraint violation" - "Data type mismatch" - "Library used incorrectly" - "Uses OS features not supported on host" - "Authorization denied" - "Auxiliary database format error" - "2nd parameter to sqlite3_bind out of range" - "File opened that is not a database file" -} - -! Return values from sqlite3_step -CONSTANT: SQLITE_ROW 100 -CONSTANT: SQLITE_DONE 101 - -! Return values from the sqlite3_column_type function -CONSTANT: SQLITE_INTEGER 1 -CONSTANT: SQLITE_FLOAT 2 -CONSTANT: SQLITE_TEXT 3 -CONSTANT: SQLITE_BLOB 4 -CONSTANT: SQLITE_NULL 5 - -! Values for the 'destructor' parameter of the 'bind' routines. -CONSTANT: SQLITE_STATIC 0 -CONSTANT: SQLITE_TRANSIENT -1 - -CONSTANT: SQLITE_OPEN_READONLY HEX: 00000001 -CONSTANT: SQLITE_OPEN_READWRITE HEX: 00000002 -CONSTANT: SQLITE_OPEN_CREATE HEX: 00000004 -CONSTANT: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008 -CONSTANT: SQLITE_OPEN_EXCLUSIVE HEX: 00000010 -CONSTANT: SQLITE_OPEN_MAIN_DB HEX: 00000100 -CONSTANT: SQLITE_OPEN_TEMP_DB HEX: 00000200 -CONSTANT: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400 -CONSTANT: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800 -CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 -CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 -CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 - -TYPEDEF: void sqlite3 -TYPEDEF: void sqlite3_stmt -TYPEDEF: longlong sqlite3_int64 -TYPEDEF: ulonglong sqlite3_uint64 - -FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ; -FUNCTION: int sqlite3_close ( sqlite3* pDb ) ; -FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ; -FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ; -FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ; -FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ; -FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; -FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ; -FUNCTION: sqlite3_uint64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; -FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ; -FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ; -FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; -FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ; -! Bind the same function as above, but for unsigned 64bit integers -: sqlite3-bind-uint64 ( pStmt index in64 -- int ) - "int" "sqlite" "sqlite3_bind_int64" - { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ; -FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ; -FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ; -FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ; -FUNCTION: int sqlite3_clear_bindings ( sqlite3_stmt* pStmt ) ; -FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ; -FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ; -! Bind the same function as above, but for unsigned 64bit integers -: sqlite3-column-uint64 ( pStmt col -- uint64 ) - "sqlite3_uint64" "sqlite" "sqlite3_column_int64" - { "sqlite3_stmt*" "int" } alien-invoke ; -FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ; diff --git a/unmaintained/db2/sqlite/introspection/authors.txt b/unmaintained/db2/sqlite/introspection/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/sqlite/introspection/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/sqlite/introspection/introspection-tests.factor b/unmaintained/db2/sqlite/introspection/introspection-tests.factor deleted file mode 100644 index d8ebc4d60e..0000000000 --- a/unmaintained/db2/sqlite/introspection/introspection-tests.factor +++ /dev/null @@ -1,38 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: db2.connections db2.introspection -db2.sqlite.introspection db2.tester db2.types tools.test ; -IN: db2.sqlite.introspection.tests - - -: test-sqlite-introspection ( -- ) - [ - { - T{ table-schema - { table "computer" } - { columns - { - T{ column - { name "name" } - { type VARCHAR } - { modifiers "" } - } - T{ column - { name "os" } - { type VARCHAR } - { modifiers "" } - } - } - } - } - } - ] [ - - sqlite-test-db [ - "computer" query-table-schema - ] with-db - ] unit-test - - ; - -[ test-sqlite-introspection ] test-sqlite diff --git a/unmaintained/db2/sqlite/introspection/introspection.factor b/unmaintained/db2/sqlite/introspection/introspection.factor deleted file mode 100644 index 41def2c558..0000000000 --- a/unmaintained/db2/sqlite/introspection/introspection.factor +++ /dev/null @@ -1,16 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays db2 db2.introspection db2.sqlite multiline -sequences ; -IN: db2.sqlite.introspection - -M: sqlite-db-connection query-table-schema* - 1array -<" -SELECT sql FROM - (SELECT * FROM sqlite_master UNION ALL - SELECT * FROM sqlite_temp_master) -WHERE type!='meta' and tbl_name = ? -ORDER BY tbl_name, type DESC, name -"> - sql-bind-query* first ; diff --git a/unmaintained/db2/sqlite/lib/lib.factor b/unmaintained/db2/sqlite/lib/lib.factor deleted file mode 100644 index e366305fcd..0000000000 --- a/unmaintained/db2/sqlite/lib/lib.factor +++ /dev/null @@ -1,110 +0,0 @@ -! Copyright (C) 2008 Chris Double, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types arrays calendar.format -combinators db2.sqlite.errors -io.backend io.encodings.string io.encodings.utf8 kernel math -namespaces present sequences serialize urls db2.sqlite.ffi ; -IN: db2.sqlite.lib - -: sqlite-check-result ( n -- ) - { - { SQLITE_OK [ ] } - { SQLITE_ERROR [ sqlite-statement-error ] } - [ throw-sqlite-error ] - } case ; - -: sqlite-open ( path -- db ) - "void*" - [ sqlite3_open sqlite-check-result ] keep *void* ; - -: sqlite-close ( db -- ) - sqlite3_close sqlite-check-result ; - -: sqlite-prepare ( db sql -- handle ) - utf8 encode dup length "void*" "void*" - [ sqlite3_prepare_v2 sqlite-check-result ] 2keep - drop *void* ; - -: sqlite-bind-parameter-index ( handle name -- index ) - sqlite3_bind_parameter_index ; - -: parameter-index ( handle name text -- handle name text ) - [ dupd sqlite-bind-parameter-index ] dip ; - -: sqlite-bind-text ( handle index text -- ) - utf8 encode dup length SQLITE_TRANSIENT - sqlite3_bind_text sqlite-check-result ; - -: sqlite-bind-int ( handle i n -- ) - sqlite3_bind_int sqlite-check-result ; - -: sqlite-bind-int64 ( handle i n -- ) - sqlite3_bind_int64 sqlite-check-result ; - -: sqlite-bind-uint64 ( handle i n -- ) - sqlite3-bind-uint64 sqlite-check-result ; - -: sqlite-bind-boolean ( handle name obj -- ) - >boolean 1 0 ? sqlite-bind-int ; - -: sqlite-bind-double ( handle i x -- ) - sqlite3_bind_double sqlite-check-result ; - -: sqlite-bind-null ( handle i -- ) - sqlite3_bind_null sqlite-check-result ; - -: sqlite-bind-blob ( handle i byte-array -- ) - dup length SQLITE_TRANSIENT - sqlite3_bind_blob sqlite-check-result ; - -: sqlite-bind-text-by-name ( handle name text -- ) - parameter-index sqlite-bind-text ; - -: sqlite-bind-int-by-name ( handle name int -- ) - parameter-index sqlite-bind-int ; - -: sqlite-bind-int64-by-name ( handle name int64 -- ) - parameter-index sqlite-bind-int64 ; - -: sqlite-bind-uint64-by-name ( handle name int64 -- ) - parameter-index sqlite-bind-uint64 ; - -: sqlite-bind-boolean-by-name ( handle name obj -- ) - >boolean 1 0 ? parameter-index sqlite-bind-int ; - -: sqlite-bind-double-by-name ( handle name double -- ) - parameter-index sqlite-bind-double ; - -: sqlite-bind-blob-by-name ( handle name blob -- ) - parameter-index sqlite-bind-blob ; - -: sqlite-bind-null-by-name ( handle name obj -- ) - parameter-index drop sqlite-bind-null ; - -: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ; -: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ; -: sqlite-clear-bindings ( handle -- ) - sqlite3_clear_bindings sqlite-check-result ; -: sqlite-#columns ( query -- int ) sqlite3_column_count ; -: sqlite-column ( handle index -- string ) sqlite3_column_text ; -: sqlite-column-name ( handle index -- string ) sqlite3_column_name ; -: sqlite-column-type ( handle index -- string ) sqlite3_column_type ; - -: sqlite-column-blob ( handle index -- byte-array/f ) - [ sqlite3_column_bytes ] 2keep - pick zero? [ - 3drop f - ] [ - sqlite3_column_blob swap memory>byte-array - ] if ; - -: sqlite-step-has-more-rows? ( prepared -- ? ) - { - { SQLITE_ROW [ t ] } - { SQLITE_DONE [ f ] } - [ sqlite-check-result f ] - } case ; - -: sqlite-next ( prepared -- ? ) - sqlite3_step sqlite-step-has-more-rows? ; - diff --git a/unmaintained/db2/sqlite/result-sets/authors.txt b/unmaintained/db2/sqlite/result-sets/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/sqlite/result-sets/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/sqlite/result-sets/result-sets.factor b/unmaintained/db2/sqlite/result-sets/result-sets.factor deleted file mode 100644 index 3b3226ef39..0000000000 --- a/unmaintained/db2/sqlite/result-sets/result-sets.factor +++ /dev/null @@ -1,30 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors db2.result-sets db2.sqlite.statements -db2.statements kernel db2.sqlite.lib destructors -db2.sqlite.types ; -IN: db2.sqlite.result-sets - -TUPLE: sqlite-result-set < result-set has-more? ; - -M: sqlite-result-set dispose - f >>handle drop ; - -M: sqlite-statement statement>result-set* - prepare-statement - sqlite-result-set new-result-set dup advance-row ; - -M: sqlite-result-set advance-row ( result-set -- ) - dup handle>> sqlite-next >>has-more? drop ; - -M: sqlite-result-set more-rows? ( result-set -- ) - has-more?>> ; - -M: sqlite-result-set #columns ( result-set -- n ) - handle>> sqlite-#columns ; - -M: sqlite-result-set column ( result-set n -- obj ) - [ handle>> ] [ sqlite-column ] bi* ; - -M: sqlite-result-set column-typed ( result-set n type -- obj ) - [ handle>> ] 2dip sqlite-type ; diff --git a/unmaintained/db2/sqlite/sqlite.factor b/unmaintained/db2/sqlite/sqlite.factor deleted file mode 100644 index 82337ae30b..0000000000 --- a/unmaintained/db2/sqlite/sqlite.factor +++ /dev/null @@ -1,12 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: constructors db2.connections ; -IN: db2.sqlite - -TUPLE: sqlite-db path ; -CONSTRUCTOR: sqlite-db ( path -- sqlite-db ) ; - -TUPLE: sqlite-db-connection < db-connection ; - -: ( handle -- db-connection ) - sqlite-db-connection new-db-connection ; diff --git a/unmaintained/db2/sqlite/statements/authors.txt b/unmaintained/db2/sqlite/statements/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/sqlite/statements/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/sqlite/statements/statements.factor b/unmaintained/db2/sqlite/statements/statements.factor deleted file mode 100644 index 0033ad06e1..0000000000 --- a/unmaintained/db2/sqlite/statements/statements.factor +++ /dev/null @@ -1,19 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors db2.connections db2.sqlite.connections -db2.sqlite.ffi db2.sqlite.lib db2.statements destructors kernel -namespaces db2.sqlite ; -IN: db2.sqlite.statements - -TUPLE: sqlite-statement < statement ; - -M: sqlite-db-connection ( string in out -- obj ) - sqlite-statement new-statement ; - -M: sqlite-statement dispose - handle>> - [ [ sqlite3_reset drop ] [ sqlite-finalize ] bi ] when* ; - -M: sqlite-statement prepare-statement* ( statement -- statement ) - db-connection get handle>> over sql>> sqlite-prepare - >>handle ; diff --git a/unmaintained/db2/sqlite/types/authors.txt b/unmaintained/db2/sqlite/types/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/sqlite/types/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/sqlite/types/types.factor b/unmaintained/db2/sqlite/types/types.factor deleted file mode 100644 index d2047c1aeb..0000000000 --- a/unmaintained/db2/sqlite/types/types.factor +++ /dev/null @@ -1,104 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays calendar.format combinators -db2.sqlite.ffi db2.sqlite.lib db2.sqlite.statements -db2.statements db2.types db2.utils fry kernel math present -sequences serialize urls ; -IN: db2.sqlite.types - -: (bind-sqlite-type) ( handle key value type -- ) - dup array? [ first ] when - { - { INTEGER [ sqlite-bind-int-by-name ] } - { BIG-INTEGER [ sqlite-bind-int64-by-name ] } - { SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] } - { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] } - { BOOLEAN [ sqlite-bind-boolean-by-name ] } - { TEXT [ sqlite-bind-text-by-name ] } - { VARCHAR [ sqlite-bind-text-by-name ] } - { DOUBLE [ sqlite-bind-double-by-name ] } - { DATE [ timestamp>ymd sqlite-bind-text-by-name ] } - { TIME [ timestamp>hms sqlite-bind-text-by-name ] } - { DATETIME [ timestamp>ymdhms sqlite-bind-text-by-name ] } - { TIMESTAMP [ timestamp>ymdhms sqlite-bind-text-by-name ] } - { BLOB [ sqlite-bind-blob-by-name ] } - { FACTOR-BLOB [ object>bytes sqlite-bind-blob-by-name ] } - { URL [ present sqlite-bind-text-by-name ] } - { +db-assigned-id+ [ sqlite-bind-int-by-name ] } - { +random-id+ [ sqlite-bind-int64-by-name ] } - { NULL [ sqlite-bind-null-by-name ] } - [ no-sql-type ] - } case ; - -: bind-next-sqlite-type ( handle key value type -- ) - dup array? [ first ] when - { - { INTEGER [ sqlite-bind-int ] } - { BIG-INTEGER [ sqlite-bind-int64 ] } - { SIGNED-BIG-INTEGER [ sqlite-bind-int64 ] } - { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64 ] } - { BOOLEAN [ sqlite-bind-boolean ] } - { TEXT [ sqlite-bind-text ] } - { VARCHAR [ sqlite-bind-text ] } - { DOUBLE [ sqlite-bind-double ] } - { DATE [ timestamp>ymd sqlite-bind-text ] } - { TIME [ timestamp>hms sqlite-bind-text ] } - { DATETIME [ timestamp>ymdhms sqlite-bind-text ] } - { TIMESTAMP [ timestamp>ymdhms sqlite-bind-text ] } - { BLOB [ sqlite-bind-blob ] } - { FACTOR-BLOB [ object>bytes sqlite-bind-blob ] } - { URL [ present sqlite-bind-text ] } - { +db-assigned-id+ [ sqlite-bind-int ] } - { +random-id+ [ sqlite-bind-int64 ] } - { NULL [ drop sqlite-bind-null ] } - [ no-sql-type ] - } case ; - -: bind-sqlite-type ( handle key value type -- ) - #! null and empty values need to be set by sqlite-bind-null-by-name - over [ - NULL = [ 2drop NULL NULL ] when - ] [ - drop NULL - ] if* (bind-sqlite-type) ; - -: sqlite-type ( handle index type -- obj ) - dup array? [ first ] when - { - { +db-assigned-id+ [ sqlite3_column_int64 ] } - { +random-id+ [ sqlite3-column-uint64 ] } - { INTEGER [ sqlite3_column_int ] } - { BIG-INTEGER [ sqlite3_column_int64 ] } - { SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] } - { UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] } - { BOOLEAN [ sqlite3_column_int 1 = ] } - { DOUBLE [ sqlite3_column_double ] } - { TEXT [ sqlite3_column_text ] } - { VARCHAR [ sqlite3_column_text ] } - { DATE [ sqlite3_column_text [ ymd>timestamp ] ?when ] } - { TIME [ sqlite3_column_text [ hms>timestamp ] ?when ] } - { TIMESTAMP [ sqlite3_column_text [ ymdhms>timestamp ] ?when ] } - { DATETIME [ sqlite3_column_text [ ymdhms>timestamp ] ?when ] } - { BLOB [ sqlite-column-blob ] } - { URL [ sqlite3_column_text [ >url ] ?when ] } - { FACTOR-BLOB [ sqlite-column-blob [ bytes>object ] ?when ] } - [ no-sql-type ] - } case ; - -M: sqlite-statement bind-sequence ( statement -- ) - [ in>> ] [ handle>> ] bi '[ - [ _ ] 2dip 1+ swap sqlite-bind-text - ] each-index ; - -M: sqlite-statement bind-typed-sequence ( statement -- ) - [ in>> ] [ handle>> ] bi '[ - [ _ ] 2dip 1+ swap first2 swap bind-next-sqlite-type - ] each-index ; - -ERROR: no-fql-type type ; - -: sqlite-type>fql-type ( string -- type ) - { - { "varchar" [ VARCHAR ] } - [ no-fql-type ] - } case ; diff --git a/unmaintained/db2/statements/authors.txt b/unmaintained/db2/statements/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/statements/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/statements/statements-tests.factor b/unmaintained/db2/statements/statements-tests.factor deleted file mode 100644 index 8a872293d9..0000000000 --- a/unmaintained/db2/statements/statements-tests.factor +++ /dev/null @@ -1,73 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test db2.statements kernel db2 db2.tester -continuations db2.errors accessors db2.types ; -IN: db2.statements.tests - -{ 1 0 } [ [ drop ] result-set-each ] must-infer-as -{ 1 1 } [ [ ] result-set-map ] must-infer-as - -: create-computer-table ( -- ) - [ "drop table computer;" sql-command ] ignore-errors - - [ "drop table computer;" sql-command ] - [ [ sql-table-missing? ] [ table>> "computer" = ] bi and ] must-fail-with - - [ ] [ - "create table computer(name varchar, os varchar, version integer);" - sql-command - ] unit-test ; - - -: test-sql-command ( -- ) - create-computer-table - - [ ] [ - "insert into computer (name, os) values('rocky', 'mac');" - sql-command - ] unit-test - - [ { { "rocky" "mac" } } ] - [ - "select name, os from computer;" - f f sql-query - ] unit-test - - [ "insert into" sql-command ] - [ sql-syntax-error? ] must-fail-with - - [ "selectt" sql-query ] - [ sql-syntax-error? ] must-fail-with - - [ ] [ - "insert into computer (name, os, version) values(?, ?, ?);" - { "clubber" "windows" "7" } - f - sql-bind-command - ] unit-test - - [ { { "windows" } } ] [ - "select os from computer where name = ?;" - { "clubber" } f sql-bind-query - ] unit-test - - [ { { "windows" 7 } } ] [ - "select os, version from computer where name = ?;" - { { VARCHAR "clubber" } } - { VARCHAR INTEGER } - sql-bind-typed-query - ] unit-test - - [ ] [ - "insert into computer (name, os, version) values(?, ?, ?);" - { - { VARCHAR "paulie" } - { VARCHAR "netbsd" } - { INTEGER 7 } - } f - sql-bind-typed-command - ] unit-test - - ; - -[ test-sql-command ] test-dbs diff --git a/unmaintained/db2/statements/statements.factor b/unmaintained/db2/statements/statements.factor deleted file mode 100644 index 9ddd74ded7..0000000000 --- a/unmaintained/db2/statements/statements.factor +++ /dev/null @@ -1,53 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors continuations destructors fry kernel -sequences db2.result-sets db2.connections db2.errors ; -IN: db2.statements - -TUPLE: statement handle sql in out type ; - -: new-statement ( sql in out class -- statement ) - new - swap >>out - swap >>in - swap >>sql ; - -HOOK: db-connection ( sql in out -- statement ) -GENERIC: statement>result-set* ( statement -- result-set ) -GENERIC: execute-statement* ( statement type -- ) -GENERIC: prepare-statement* ( statement -- statement' ) -GENERIC: bind-sequence ( statement -- ) -GENERIC: bind-typed-sequence ( statement -- ) - -: statement>result-set ( statement -- result-set ) - [ statement>result-set* ] - [ dup sql-error? [ parse-sql-error ] when rethrow ] recover ; - -M: object execute-statement* ( statement type -- ) - drop statement>result-set dispose ; - -: execute-one-statement ( statement -- ) - dup type>> execute-statement* ; - -: execute-statement ( statement -- ) - dup sequence? - [ [ execute-one-statement ] each ] - [ execute-one-statement ] if ; - -: prepare-statement ( statement -- statement ) - dup handle>> [ prepare-statement* ] unless ; - -: result-set-each ( statement quot: ( statement -- ) -- ) - over more-rows? - [ [ call ] 2keep over advance-row result-set-each ] - [ 2drop ] if ; inline recursive - -: result-set-map ( statement quot -- sequence ) - accumulator [ result-set-each ] dip { } like ; inline - -: statement>result-sequence ( statement -- sequence ) - statement>result-set [ [ sql-row ] result-set-map ] with-disposal ; - -: statement>typed-result-sequence ( statement -- sequence ) - statement>result-set - [ [ sql-row-typed ] result-set-map ] with-disposal ; diff --git a/unmaintained/db2/tester/authors.txt b/unmaintained/db2/tester/authors.txt deleted file mode 100644 index f372b574ae..0000000000 --- a/unmaintained/db2/tester/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Slava Pestov -Doug Coleman diff --git a/unmaintained/db2/tester/tester-tests.factor b/unmaintained/db2/tester/tester-tests.factor deleted file mode 100644 index b3e8f19e6a..0000000000 --- a/unmaintained/db2/tester/tester-tests.factor +++ /dev/null @@ -1,7 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test db2.tester ; -IN: db2.tester.tests - -! [ ] [ sqlite-test-db db-tester ] unit-test -! [ ] [ sqlite-test-db db-tester2 ] unit-test diff --git a/unmaintained/db2/tester/tester.factor b/unmaintained/db2/tester/tester.factor deleted file mode 100644 index 471752f413..0000000000 --- a/unmaintained/db2/tester/tester.factor +++ /dev/null @@ -1,96 +0,0 @@ -! Copyright (C) 2008 Slava Pestov, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: concurrency.combinators db2.connections -db2.pools db2.sqlite db2.types fry io.files.temp kernel math -namespaces random threads tools.test combinators ; -IN: db2.tester -USE: multiline - -: sqlite-test-db ( -- sqlite-db ) - "tuples-test.db" temp-file ; - -! These words leak resources, but are useful for interactivel testing -: set-sqlite-db ( -- ) - sqlite-db db-open db-connection set ; - -: test-sqlite ( quot -- ) - '[ - [ ] [ sqlite-test-db _ with-db ] unit-test - ] call ; inline - -: test-dbs ( quot -- ) - { - [ test-sqlite ] - } cleave ; - -/* -: postgresql-test-db ( -- postgresql-db ) - - "localhost" >>host - "postgres" >>username - "thepasswordistrust" >>password - "factor-test" >>database ; - -: set-postgresql-db ( -- ) - postgresql-db db-open db-connection set ; - -: test-postgresql ( quot -- ) - '[ - os windows? cpu x86.64? and [ - [ ] [ postgresql-test-db _ with-db ] unit-test - ] unless - ] call ; inline - -TUPLE: test-1 id a b c ; - -test-1 "TEST1" { - { "id" "ID" INTEGER +db-assigned-id+ } - { "a" "A" { VARCHAR 256 } +not-null+ } - { "b" "B" { VARCHAR 256 } +not-null+ } - { "c" "C" { VARCHAR 256 } +not-null+ } -} define-persistent - -TUPLE: test-2 id x y z ; - -test-2 "TEST2" { - { "id" "ID" INTEGER +db-assigned-id+ } - { "x" "X" { VARCHAR 256 } +not-null+ } - { "y" "Y" { VARCHAR 256 } +not-null+ } - { "z" "Z" { VARCHAR 256 } +not-null+ } -} define-persistent - -: db-tester ( test-db -- ) - [ - [ - test-1 ensure-table - test-2 ensure-table - ] with-db - ] [ - 10 [ - drop - 10 [ - dup [ - f 100 random 100 random 100 random test-1 boa - insert-tuple yield - ] with-db - ] times - ] with parallel-each - ] bi ; - -: db-tester2 ( test-db -- ) - [ - [ - test-1 ensure-table - test-2 ensure-table - ] with-db - ] [ - [ - 10 [ - 10 [ - f 100 random 100 random 100 random test-1 boa - insert-tuple yield - ] times - ] parallel-each - ] with-pooled-db - ] bi ; -*/ diff --git a/unmaintained/db2/transactions/authors.txt b/unmaintained/db2/transactions/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/transactions/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/transactions/transactions.factor b/unmaintained/db2/transactions/transactions.factor deleted file mode 100644 index fd0e6ade74..0000000000 --- a/unmaintained/db2/transactions/transactions.factor +++ /dev/null @@ -1,26 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: continuations db2 db2.connections namespaces ; -IN: db2.transactions - -SYMBOL: in-transaction - -HOOK: begin-transaction db-connection ( -- ) - -HOOK: commit-transaction db-connection ( -- ) - -HOOK: rollback-transaction db-connection ( -- ) - -M: db-connection begin-transaction ( -- ) "BEGIN" sql-command ; - -M: db-connection commit-transaction ( -- ) "COMMIT" sql-command ; - -M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ; - -: in-transaction? ( -- ? ) in-transaction get ; - -: with-transaction ( quot -- ) - t in-transaction [ - begin-transaction - [ ] [ rollback-transaction ] cleanup commit-transaction - ] with-variable ; inline diff --git a/unmaintained/db2/types/authors.txt b/unmaintained/db2/types/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/types/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/types/types.factor b/unmaintained/db2/types/types.factor deleted file mode 100644 index 97f9ca0a0c..0000000000 --- a/unmaintained/db2/types/types.factor +++ /dev/null @@ -1,17 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: ; -IN: db2.types - -SINGLETONS: +db-assigned-id+ +user-assigned-id+ +random-id+ ; -UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ; - -SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ -+foreign-id+ +has-many+ +on-update+ +on-delete+ +restrict+ +cascade+ -+set-null+ +set-default+ ; - -SINGLETONS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER -DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB -FACTOR-BLOB NULL URL ; - -ERROR: no-sql-type type ; diff --git a/unmaintained/db2/utils/authors.txt b/unmaintained/db2/utils/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/utils/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/utils/utils.factor b/unmaintained/db2/utils/utils.factor deleted file mode 100644 index 0557593209..0000000000 --- a/unmaintained/db2/utils/utils.factor +++ /dev/null @@ -1,32 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.parser strings sequences -words ; -IN: db2.utils - -: ?when ( object quot -- object' ) dupd when ; inline -: ?1array ( obj -- array ) dup string? [ 1array ] when ; inline -: ??1array ( obj -- array/f ) [ ?1array ] ?when ; inline - -: ?first ( sequence -- object/f ) 0 ?nth ; -: ?second ( sequence -- object/f ) 1 ?nth ; - -: ?first2 ( sequence -- object1/f object2/f ) - [ ?first ] [ ?second ] bi ; - -: assoc-with ( object sequence quot -- obj curry ) - swapd [ [ -rot ] dip call ] 2curry ; inline - -: ?number>string ( n/string -- string ) - dup number? [ number>string ] when ; - -ERROR: no-accessor name ; - -: lookup-accessor ( string -- accessor ) - dup ">>" append "accessors" lookup - [ nip ] [ no-accessor ] if* ; - -ERROR: string-expected object ; - -: ensure-string ( object -- string ) - dup string? [ string-expected ] unless ; From a9b4a724a41ca37eb21539dac9c3ccb3f536fabe Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 03:23:11 -0500 Subject: [PATCH 75/98] Remove "compiled-status" word prop and simplify associated machinery --- basis/compiler/compiler.factor | 37 +++++++++---------------- basis/macros/macros.factor | 9 +++--- basis/tools/deploy/shaker/shaker.factor | 1 - core/definitions/definitions.factor | 3 -- core/words/words.factor | 17 ++++++++---- 5 files changed, 30 insertions(+), 37 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index b8ba620f32..717f66ba88 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -28,23 +28,14 @@ SYMBOL: compiled : maybe-compile ( word -- ) dup optimized>> [ drop ] [ queue-compile ] if ; -SYMBOLS: +optimized+ +unoptimized+ ; +: recompile-callers? ( word -- ? ) + changed-effects get key? ; -: ripple-up ( words -- ) - dup "compiled-status" word-prop +unoptimized+ eq? - [ usage [ word? ] filter ] [ compiled-usage keys ] if - [ queue-compile ] each ; - -: ripple-up? ( status word -- ? ) - [ - [ nip changed-effects get key? ] - [ "compiled-status" word-prop eq? not ] 2bi or - ] keep "compiled-status" word-prop and ; - -: save-compiled-status ( word status -- ) - [ over ripple-up? [ ripple-up ] [ drop ] if ] - [ "compiled-status" set-word-prop ] - 2bi ; +: recompile-callers ( words -- ) + dup recompile-callers? [ + [ usage [ word? ] filter ] [ compiled-usage keys ] bi + [ [ queue-compile ] each ] bi@ + ] [ drop ] if ; : start ( word -- ) "trace-compilation" get [ dup name>> print flush ] when @@ -55,20 +46,19 @@ SYMBOLS: +optimized+ +unoptimized+ ; : ignore-error? ( word error -- ? ) [ { - [ inline? ] [ macro? ] - [ "no-compile" word-prop ] + [ inline? ] [ "special" word-prop ] + [ "no-compile" word-prop ] } 1|| ] [ error-type +compiler-warning+ eq? ] bi* and ; : (fail) ( word compiled -- * ) swap + [ recompile-callers ] [ compiled-unxref ] [ compiled get set-at ] - [ +unoptimized+ save-compiled-status ] - tri - return ; + tri return ; : not-compiled-def ( word error -- def ) '[ _ _ not-compiled ] [ ] like ; @@ -106,11 +96,10 @@ t compile-dependencies? set-global ] each ; : finish ( word -- ) - [ +optimized+ save-compiled-status ] + [ recompile-callers ] [ compiled-unxref ] [ - dup crossref? - [ + dup crossref? [ dependencies get generic-dependencies get compiled-xref diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index a86b711340..0e5ef30f51 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -12,10 +12,11 @@ IN: macros PRIVATE> : define-macro ( word definition effect -- ) - real-macro-effect - [ [ memoize-quot [ call ] append ] keep define-declared ] - [ drop "macro" set-word-prop ] - 3bi ; + real-macro-effect { + [ [ memoize-quot [ call ] append ] keep define-declared ] + [ drop "macro" set-word-prop ] + [ 2drop changed-effect ] + } 3cleave ; SYNTAX: MACRO: (:) define-macro ; diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 807abe4d58..0d7d8fd7c6 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -99,7 +99,6 @@ IN: tools.deploy.shaker "boa-check" "coercer" "combination" - "compiled-status" "compiled-generic-uses" "compiled-uses" "constraints" diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 7463a863e5..1a26e45e87 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -19,9 +19,6 @@ SYMBOL: changed-definitions SYMBOL: changed-effects -: changed-effect ( word -- ) - dup changed-effects get set-in-unit ; - SYMBOL: changed-generics SYMBOL: outdated-generics diff --git a/core/words/words.factor b/core/words/words.factor index 97225c0f75..1a2317997a 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -138,12 +138,15 @@ M: word subwords drop f ; >>def dup crossref? [ dup xref ] when drop ; +: changed-effect ( word -- ) + [ dup changed-effects get set-in-unit ] + [ dup primitive? [ drop ] [ changed-definition ] if ] bi ; + : set-stack-effect ( effect word -- ) 2dup "declared-effect" word-prop = [ 2drop ] [ - swap - [ drop changed-effect ] - [ "declared-effect" set-word-prop ] - [ drop dup primitive? [ drop ] [ changed-definition ] if ] + [ nip changed-effect ] + [ nip subwords [ changed-effect ] each ] + [ swap "declared-effect" set-word-prop ] 2tri ] if ; @@ -151,7 +154,11 @@ M: word subwords drop f ; [ nip swap set-stack-effect ] [ drop define ] 3bi ; : make-inline ( word -- ) - t "inline" set-word-prop ; + dup inline? [ drop ] [ + [ t "inline" set-word-prop ] + [ changed-effect ] + bi + ] if ; : make-recursive ( word -- ) t "recursive" set-word-prop ; From 469c9ee21d93b9b8a29aa81bb5cef7c3fb74083f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 16:09:53 -0500 Subject: [PATCH 76/98] Debugging stack checking --- basis/compiler/tests/redefine0.factor | 74 +++++++++++++++++++ basis/compiler/tests/redefine16.factor | 4 +- basis/compiler/tree/builder/builder.factor | 2 +- .../compiler/tree/optimizer/optimizer.factor | 1 - .../tree/propagation/inlining/inlining.factor | 12 +-- .../known-words/known-words.factor | 5 ++ .../known-words/known-words.factor | 5 +- core/classes/tuple/tuple-tests.factor | 45 ++++------- core/compiler/units/units-tests.factor | 8 +- 9 files changed, 111 insertions(+), 45 deletions(-) create mode 100644 basis/compiler/tests/redefine0.factor diff --git a/basis/compiler/tests/redefine0.factor b/basis/compiler/tests/redefine0.factor new file mode 100644 index 0000000000..cdef7103ce --- /dev/null +++ b/basis/compiler/tests/redefine0.factor @@ -0,0 +1,74 @@ +IN: compiler.tests.redefine0 +USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math ; + +! Test ripple-up behavior +: test-1 ( -- a ) 3 ; +: test-2 ( -- ) test-1 ; + +[ test-2 ] [ not-compiled? ] must-fail-with + +[ ] [ "IN: compiler.tests.redefine0 : test-1 ( -- ) ;" eval( -- ) ] unit-test + +{ 0 0 } [ test-1 ] must-infer-as + +[ ] [ test-2 ] unit-test + +[ ] [ + [ + \ test-1 forget + \ test-2 forget + ] with-compilation-unit +] unit-test + +: test-3 ( a -- ) drop ; +: test-4 ( -- ) [ 1 2 3 ] test-3 ; + +[ ] [ test-4 ] unit-test + +[ ] [ "IN: compiler.tests.redefine0 USE: kernel : test-3 ( a -- ) call ; inline" eval( -- ) ] unit-test + +[ test-4 ] [ not-compiled? ] must-fail-with + +[ ] [ + [ + \ test-3 forget + \ test-4 forget + ] with-compilation-unit +] unit-test + +: test-5 ( a -- quot ) ; +: test-6 ( a -- b ) test-5 ; + +[ 31337 ] [ 31337 test-6 ] unit-test + +[ ] [ "IN: compiler.tests.redefine0 USING: macros kernel ; MACRO: test-5 ( a -- quot ) drop [ ] ;" eval( -- ) ] unit-test + +[ 31337 test-6 ] [ not-compiled? ] must-fail-with + +[ ] [ + [ + \ test-5 forget + \ test-6 forget + ] with-compilation-unit +] unit-test + +GENERIC: test-7 ( a -- b ) + +M: integer test-7 + ; + +: test-8 ( a -- b ) 255 bitand test-7 ; + +[ 1 test-7 ] [ not-compiled? ] must-fail-with +[ 1 test-8 ] [ not-compiled? ] must-fail-with + +[ ] [ "IN: compiler.tests.redefine0 USING: macros kernel ; GENERIC: test-7 ( x y -- z )" eval( -- ) ] unit-test + +[ 4 ] [ 1 3 test-7 ] unit-test +[ 4 ] [ 1 259 test-8 ] unit-test + +[ ] [ + [ + \ test-7 forget + \ test-8 forget + ] with-compilation-unit +] unit-test diff --git a/basis/compiler/tests/redefine16.factor b/basis/compiler/tests/redefine16.factor index 264b9b0675..3bef30f9f1 100644 --- a/basis/compiler/tests/redefine16.factor +++ b/basis/compiler/tests/redefine16.factor @@ -6,4 +6,6 @@ quotations stack-checker ; [ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test [ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test -[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test \ No newline at end of file +[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test + +[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index bda64569c3..05e6c5a14f 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -25,7 +25,7 @@ IN: compiler.tree.builder [ f initial-recursive-state infer-quot ] bi* ] with-tree-builder unclip-last in-d>> - ] [ "OOPS" USE: io print flush 3drop f f ] recover ; + ] [ 3drop f f ] recover ; : build-sub-tree ( #call quot -- nodes/f ) [ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index daa8f072ca..fe3c7acb92 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -29,7 +29,6 @@ SYMBOL: check-optimizer? normalize propagate cleanup - ?check dup run-escape-analysis? [ escape-analysis unbox-tuples diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index b26ce3bed9..8e9476a7ed 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -166,9 +166,9 @@ SYMBOL: history [ history [ swap suffix ] change ] bi ; -:: inline-word-def ( #call word quot -- ? ) +:: inline-word ( #call word -- ? ) word history get memq? [ f ] [ - #call quot splicing-nodes [ + #call word specialized-def splicing-nodes [ [ word remember-inlining [ ] [ count-nodes ] [ (propagate) ] tri @@ -177,9 +177,6 @@ SYMBOL: history ] [ f ] if* ] if ; -: inline-word ( #call word -- ? ) - dup specialized-def inline-word-def ; - : inline-method-body ( #call word -- ? ) 2dup should-inline? [ inline-word ] [ 2drop f ] if ; @@ -199,10 +196,6 @@ SYMBOL: history call( #call -- word/quot/f ) object swap eliminate-dispatch ; -: inline-instance-check ( #call word -- ? ) - over in-d>> second value-info literal>> dup class? - [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ; - : (do-inlining) ( #call word -- ? ) #! If the generic was defined in an outer compilation unit, #! then it doesn't have a definition yet; the definition @@ -214,7 +207,6 @@ SYMBOL: history #! discouraged, but it should still work.) { { [ dup never-inline-word? ] [ 2drop f ] } - { [ dup \ instance? eq? ] [ inline-instance-check ] } { [ dup always-inline-word? ] [ inline-word ] } { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 1b5d383353..b91a1157f7 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -341,6 +341,11 @@ generic-comparison-ops [ ] [ 2drop object-info ] if ] "outputs" set-word-prop +\ instance? [ + in-d>> second value-info literal>> dup class? + [ "predicate" word-prop '[ drop @ ] ] [ drop f ] if +] "custom-inlining" set-word-prop + \ equal? [ ! If first input has a known type and second input is an ! object, we convert this to [ swap equal? ]. diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 85aa9030f8..37059c19d0 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -216,7 +216,10 @@ M: object infer-call* dispatch exit load-local load-locals get-local drop-locals do-primitive alien-invoke alien-indirect alien-callback -} [ t "special" set-word-prop ] each +} [ + [ t "special" set-word-prop ] + [ t "no-compile" set-word-prop ] bi +] each M\ quotation call t "no-compile" set-word-prop M\ curry call t "no-compile" set-word-prop diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 3800d5056a..4b556396e2 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -5,7 +5,7 @@ generic.standard effects classes.tuple classes.tuple.private arrays vectors strings compiler.units accessors classes.algebra calendar prettyprint io.streams.string splitting summary columns math.order classes.private slots slots.private eval see -words.symbol ; +words.symbol compiler.errors ; IN: classes.tuple.tests TUPLE: rect x y w h ; @@ -34,9 +34,7 @@ C: redefinition-test ! Make sure we handle changing shapes! TUPLE: point x y ; -C: point - -[ ] [ 100 200 "p" set ] unit-test +[ ] [ 100 200 point boa "p" set ] unit-test ! Use eval to sequence parsing explicitly [ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval( -- ) ] unit-test @@ -199,17 +197,6 @@ TUPLE: erg's-reshape-problem a b c d ; C: erg's-reshape-problem -! We want to make sure constructors are recompiled when -! tuples are reshaped -: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ; -: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ; - -[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval( -- ) ] unit-test - -[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test - -[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test - ! Inheritance TUPLE: computer cpu ram ; C: computer @@ -287,7 +274,7 @@ test-server-slot-values ! Dynamically changing inheritance hierarchy TUPLE: electronic-device ; -[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ; C: computer C: laptop C: server" eval( -- ) ] unit-test [ f ] [ electronic-device laptop class<= ] unit-test [ t ] [ server electronic-device class<= ] unit-test @@ -303,17 +290,17 @@ TUPLE: electronic-device ; [ f ] [ "server" get laptop? ] unit-test [ t ] [ "server" get server? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ; C: computer C: laptop C: server" eval( -- ) ] unit-test [ f ] [ "laptop" get electronic-device? ] unit-test [ t ] [ "laptop" get computer? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ; C: computer C: laptop C: server" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; C: computer C: laptop C: server" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -326,7 +313,7 @@ TUPLE: make-me-some-accessors voltage grounded? ; [ ] [ "laptop" get 220 >>voltage drop ] unit-test [ ] [ "server" get 110 >>voltage drop ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ; C: computer" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -334,7 +321,7 @@ test-server-slot-values [ 220 ] [ "laptop" get voltage>> ] unit-test [ 110 ] [ "server" get voltage>> ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ; C: computer C: laptop C: server" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -343,7 +330,7 @@ test-server-slot-values [ 110 ] [ "server" get voltage>> ] unit-test ! Reshaping superclass and subclass simultaneously -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ; C: computer C: laptop C: server" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -354,9 +341,7 @@ test-server-slot-values ! Reshape crash TUPLE: test1 a ; TUPLE: test2 < test1 b ; -C: test2 - -"a" "b" "test" set +"a" "b" test2 boa "test" set : test-a/b ( -- ) [ "a" ] [ "test" get a>> ] unit-test @@ -412,15 +397,17 @@ TUPLE: constructor-update-1 xxx ; TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ; -C: constructor-update-2 +: ( a b c -- tuple ) constructor-update-2 boa ; { 3 1 } [ ] must-infer-as [ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval( -- ) ] unit-test -{ 5 1 } [ ] must-infer-as +{ 3 1 } [ ] must-infer-as -[ { 1 2 3 4 5 } ] [ 1 2 3 4 5 tuple-slots ] unit-test +[ 1 2 3 4 5 ] [ not-compiled? ] must-fail-with + +[ ] [ [ \ forget ] with-compilation-unit ] unit-test ! Redefinition problem TUPLE: redefinition-problem ; @@ -623,7 +610,7 @@ must-fail-with : blah ( -- vec ) vector new ; -\ blah must-infer +[ vector new ] must-infer [ V{ } ] [ blah ] unit-test diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index 57726cc269..0b74f3a236 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -1,4 +1,4 @@ -USING: definitions compiler.units tools.test arrays sequences words kernel +USING: compiler definitions compiler.units tools.test arrays sequences words kernel accessors namespaces fry eval ; IN: compiler.units.tests @@ -14,11 +14,13 @@ IN: compiler.units.tests ! Non-optimizing compiler bugs [ 1 1 ] [ - "A" "B" [ [ 1 ] dip ] 2array 1array modify-code-heap + "A" "B" [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep 1 swap execute ] unit-test [ "A" "B" ] [ + disable-compiler + gensym "a" set gensym "b" set [ @@ -30,6 +32,8 @@ IN: compiler.units.tests "a" get [ "B" ] define ] with-compilation-unit "b" get execute + + enable-compiler ] unit-test ! Notify observers even if compilation unit did nothing From 3d5995b3b4faadd0e71e604f0ef1a01c67abba40 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 16:10:42 -0500 Subject: [PATCH 77/98] Two quick fixes --- basis/compiler/tree/optimizer/optimizer.factor | 1 - basis/compiler/tree/propagation/inlining/inlining.factor | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index daa8f072ca..fe3c7acb92 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -29,7 +29,6 @@ SYMBOL: check-optimizer? normalize propagate cleanup - ?check dup run-escape-analysis? [ escape-analysis unbox-tuples diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 7ae44a5293..df9c7be024 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -170,7 +170,7 @@ SYMBOL: history ] if ; : inline-word ( #call word -- ? ) - dup specialized-def inline-word-def ; + dup def>> inline-word-def ; : inline-method-body ( #call word -- ? ) 2dup should-inline? [ inline-word ] [ 2drop f ] if ; From bd8787d540f624d6a2c4211d7e4d3ae37e871fa0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 16:23:54 -0500 Subject: [PATCH 78/98] Tweak unit test in classes vocab to yield more information on failure --- core/classes/classes-tests.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 08746d1ba7..61d153f064 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -3,7 +3,7 @@ io.streams.string kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate classes.algebra vectors definitions source-files compiler.units -kernel.private sorting vocabs memory eval accessors ; +kernel.private sorting vocabs memory eval accessors sets ; IN: classes.tests [ t ] [ 3 object instance? ] unit-test @@ -22,10 +22,11 @@ M: method-forget-class method-forget-test ; [ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test [ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test -[ t ] [ +[ { } { } ] [ all-words [ class? ] filter implementors-map get keys - [ natural-sort ] bi@ = + [ natural-sort ] bi@ + [ diff ] [ swap diff ] 2bi ] unit-test ! Minor leak From b18081929c70920265194d37528ca37846c6228e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 16:25:04 -0500 Subject: [PATCH 79/98] Remove copyright notice from license --- license.txt | 2 -- 1 file changed, 2 deletions(-) diff --git a/license.txt b/license.txt index 8f4f53585a..e9cd58a5e4 100644 --- a/license.txt +++ b/license.txt @@ -1,5 +1,3 @@ -Copyright (C) 2003, 2009 Slava Pestov and friends. - Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: From 24a22e233c80678868015243b316d85b0c844b0c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 22:33:04 -0500 Subject: [PATCH 80/98] Clean up compiler vocab --- basis/compiler/compiler.factor | 75 +++++++++++++++++++++------------- 1 file changed, 46 insertions(+), 29 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 717f66ba88..6094efad87 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -15,6 +15,7 @@ SYMBOL: compile-queue SYMBOL: compiled : queue-compile? ( word -- ? ) + #! Don't attempt to compile certain words. { [ "forgotten" word-prop ] [ compiled get key? ] @@ -25,17 +26,14 @@ SYMBOL: compiled : queue-compile ( word -- ) dup queue-compile? [ compile-queue get push-front ] [ drop ] if ; -: maybe-compile ( word -- ) - dup optimized>> [ drop ] [ queue-compile ] if ; - : recompile-callers? ( word -- ? ) changed-effects get key? ; : recompile-callers ( words -- ) - dup recompile-callers? [ - [ usage [ word? ] filter ] [ compiled-usage keys ] bi - [ [ queue-compile ] each ] bi@ - ] [ drop ] if ; + #! If a word's stack effect changed, recompile all words that + #! have compiled calls to it. + dup recompile-callers? + [ compiled-usage keys [ queue-compile ] each ] [ drop ] if ; : start ( word -- ) "trace-compilation" get [ dup name>> print flush ] when @@ -44,6 +42,8 @@ SYMBOL: compiled f swap compiler-error ; : ignore-error? ( word error -- ? ) + #! Ignore warnings on inline combinators, macros, and special + #! words such as 'call'. [ { [ macro? ] @@ -53,35 +53,61 @@ SYMBOL: compiled } 1|| ] [ error-type +compiler-warning+ eq? ] bi* and ; -: (fail) ( word compiled -- * ) - swap +: finish ( word -- ) + #! Recompile callers if the word's stack effect changed, then + #! save the word's dependencies so that if they change, the + #! word can get recompiled too. [ recompile-callers ] [ compiled-unxref ] - [ compiled get set-at ] - tri return ; + [ + dup crossref? [ + dependencies get + generic-dependencies get + compiled-xref + ] [ drop ] if + ] tri ; + +: deoptimize-with ( word def -- * ) + #! If the word failed to infer, compile it with the + #! non-optimizing compiler. + swap [ finish ] [ compiled get set-at ] bi return ; : not-compiled-def ( word error -- def ) '[ _ _ not-compiled ] [ ] like ; -: fail ( word error -- * ) +: deoptimize ( word error -- * ) + #! If the error is ignorable, compile the word with the + #! non-optimizing compiler, using its definition. Otherwise, + #! if the compiler error is not ignorable, use a dummy + #! definition from 'not-compiled-def' which throws an error. 2dup ignore-error? [ drop f over def>> ] [ 2dup not-compiled-def ] if - [ swap compiler-error ] [ (fail) ] bi-curry* bi ; + [ swap compiler-error ] [ deoptimize-with ] bi-curry* bi ; : frontend ( word -- nodes ) - dup contains-breakpoints? [ dup def>> (fail) ] [ - [ build-tree-from-word ] [ fail ] recover optimize-tree + #! If the word contains breakpoints, don't optimize it, since + #! the walker does not support this. + dup contains-breakpoints? [ dup def>> deoptimize-with ] [ + [ build-tree ] [ deoptimize ] recover optimize-tree ] if ; +: compile-dependency ( word -- ) + #! If a word calls an unoptimized word, try to compile the callee. + dup optimized>> [ drop ] [ queue-compile ] if ; + ! Only switch this off for debugging. SYMBOL: compile-dependencies? t compile-dependencies? set-global +: compile-dependencies ( asm -- ) + compile-dependencies? get + [ calls>> [ compile-dependency ] each ] [ drop ] if ; + : save-asm ( asm -- ) [ [ code>> ] [ label>> ] bi compiled get set-at ] - [ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ] + [ compile-dependencies ] bi ; : backend ( nodes word -- ) @@ -95,18 +121,9 @@ t compile-dependencies? set-global save-asm ] each ; -: finish ( word -- ) - [ recompile-callers ] - [ compiled-unxref ] - [ - dup crossref? [ - dependencies get - generic-dependencies get - compiled-xref - ] [ drop ] if - ] tri ; - -: (compile) ( word -- ) +: compile-word ( word -- ) + #! We return early if the word has breakpoints or if it + #! failed to infer. '[ _ { [ start ] @@ -117,7 +134,7 @@ t compile-dependencies? set-global ] with-return ; : compile-loop ( deque -- ) - [ (compile) yield-hook get call( -- ) ] slurp-deque ; + [ compile-word yield-hook get call( -- ) ] slurp-deque ; : decompile ( word -- ) dup def>> 2array 1array modify-code-heap ; From 057f75e9a14e7f04b778afaa9bc251cb23f9bbd6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 23:02:00 -0500 Subject: [PATCH 81/98] Refactor compiler.tree.builder to fix various regressions --- basis/bootstrap/compiler/compiler.factor | 2 +- basis/compiler/cfg/debugger/debugger.factor | 2 +- basis/compiler/compiler-docs.factor | 8 +- basis/compiler/tests/optimizer.factor | 2 +- basis/compiler/tests/redefine0.factor | 37 +++++++++- .../compiler/tree/builder/builder-docs.factor | 9 +-- .../tree/builder/builder-tests.factor | 8 +- basis/compiler/tree/builder/builder.factor | 74 ++++++++++--------- basis/compiler/tree/checker/checker.factor | 12 +-- basis/compiler/tree/debugger/debugger.factor | 3 +- .../compiler/tree/optimizer/optimizer.factor | 1 + .../tree/propagation/inlining/inlining.factor | 14 ++-- basis/stack-checker/backend/backend.factor | 16 ++-- .../known-words/known-words.factor | 4 + .../stack-checker/stack-checker-tests.factor | 2 +- basis/stack-checker/state/state.factor | 1 + 16 files changed, 121 insertions(+), 74 deletions(-) diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 617073bbc4..89a0ed86fe 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -108,7 +108,7 @@ nl "." write flush -{ (compile) } compile-unoptimized +{ compile-word } compile-unoptimized "." write flush diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index 6d0a8f8c8e..6b0aba6813 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -16,7 +16,7 @@ M: callable test-cfg build-tree optimize-tree gensym build-cfg ; M: word test-cfg - [ build-tree-from-word optimize-tree ] keep build-cfg ; + [ build-tree optimize-tree ] keep build-cfg ; SYMBOL: allocate-registers? diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index f92f0015d3..cdd410457c 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -27,12 +27,12 @@ $nl { $subsection compile-queue } "Once compiled, a word is added to the assoc stored in the " { $link compiled } " variable. When compilation is complete, this assoc is passed to " { $link modify-code-heap } "." $nl -"The " { $link (compile) } " word performs the actual task of compiling an individual word. The process proceeds as follows:" +"The " { $link compile-word } " word performs the actual task of compiling an individual word. The process proceeds as follows:" { $list - { "The " { $link frontend } " word calls " { $link build-tree-from-word } ". If this fails, the error is passed to " { $link fail } ". The logic for ignoring compile warnings generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." } + { "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". The logic for ignoring compile warnings generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." } { "If the word contains a breakpoint, compilation ends here. Otherwise, all remaining steps execute until machine code is generated. Any further errors thrown by the compiler are not reported as compile errors, but instead are ordinary exceptions. This is because they indicate bugs in the compiler, not errors in user code." } { "The " { $link frontend } " word then calls " { $link optimize-tree } ". This produces the final optimized tree IR, and this stage of the compiler is complete." } - { "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link maybe-compile } "." } + { "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link compile-dependency } "." } } "If compilation fails, the word is stored in the " { $link compiled } " assoc with a value of " { $link f } ". This causes the VM to compile the word with the non-optimizing compiler." $nl @@ -60,7 +60,7 @@ HELP: decompile { $values { "word" word } } { $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ; -HELP: (compile) +HELP: compile-word { $values { "word" word } } { $description "Compile a single word." } { $notes "This is an internal word, and user code should call " { $link compile } " instead." } ; diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 23b69b06b9..99bdb18812 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -303,7 +303,7 @@ HINTS: recursive-inline-hang-3 array ; : member-test ( obj -- ? ) { + - * / /i } member? ; \ member-test def>> must-infer -[ ] [ \ member-test build-tree-from-word optimize-tree drop ] unit-test +[ ] [ \ member-test build-tree optimize-tree drop ] unit-test [ t ] [ \ + member-test ] unit-test [ f ] [ \ append member-test ] unit-test diff --git a/basis/compiler/tests/redefine0.factor b/basis/compiler/tests/redefine0.factor index cdef7103ce..87b63aa029 100644 --- a/basis/compiler/tests/redefine0.factor +++ b/basis/compiler/tests/redefine0.factor @@ -1,5 +1,6 @@ IN: compiler.tests.redefine0 -USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math ; +USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math +namespaces macros assocs ; ! Test ripple-up behavior : test-1 ( -- a ) 3 ; @@ -61,7 +62,7 @@ M: integer test-7 + ; [ 1 test-7 ] [ not-compiled? ] must-fail-with [ 1 test-8 ] [ not-compiled? ] must-fail-with -[ ] [ "IN: compiler.tests.redefine0 USING: macros kernel ; GENERIC: test-7 ( x y -- z )" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine0 USING: macros math kernel ; GENERIC: test-7 ( x y -- z ) : test-8 ( a b -- c ) 255 bitand test-7 ;" eval( -- ) ] unit-test [ 4 ] [ 1 3 test-7 ] unit-test [ 4 ] [ 1 259 test-8 ] unit-test @@ -72,3 +73,35 @@ M: integer test-7 + ; \ test-8 forget ] with-compilation-unit ] unit-test + +! Indirect dependency on an unoptimized word +: test-9 ( -- ) ; +<< SYMBOL: quot +[ test-9 ] quot set-global >> +MACRO: test-10 ( -- quot ) quot get ; +: test-11 ( -- ) test-10 ; + +[ ] [ test-11 ] unit-test + +[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) 1 ;" eval( -- ) ] unit-test + +! test-11 should get recompiled now + +[ test-11 ] [ not-compiled? ] must-fail-with + +[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- a ) 1 ;" eval( -- ) ] unit-test + +[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) ;" eval( -- ) ] unit-test + +[ ] [ test-11 ] unit-test + +quot global delete-at + +[ ] [ + [ + \ test-9 forget + \ test-10 forget + \ test-11 forget + \ quot forget + ] with-compilation-unit +] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/builder/builder-docs.factor b/basis/compiler/tree/builder/builder-docs.factor index 8cf3796f0a..3fa576faf5 100644 --- a/basis/compiler/tree/builder/builder-docs.factor +++ b/basis/compiler/tree/builder/builder-docs.factor @@ -3,12 +3,11 @@ compiler.tree stack-checker.errors ; IN: compiler.tree.builder HELP: build-tree -{ $values { "quot" quotation } { "nodes" "a sequence of nodes" } } +{ $values { "quot/word" { $or quotation word } } { "nodes" "a sequence of nodes" } } { $description "Attempts to construct tree SSA IR from a quotation." } { $notes "This is the first stage of the compiler." } { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; -HELP: build-tree-with -{ $values { "in-stack" "a sequence of values" } { "quot" quotation } { "nodes" "a sequence of nodes" } { "out-stack" "a sequence of values" } } -{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values, and outputting stack resulting at the end." } -{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; +HELP: build-sub-tree +{ $values { "#call" #call } { "quot/word" { $or quotation word } } { "nodes" { $maybe "a sequence of nodes" } } } +{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values from the call site. Outputs " { $link f } " if stack effect inference fails." } ; diff --git a/basis/compiler/tree/builder/builder-tests.factor b/basis/compiler/tree/builder/builder-tests.factor index 9668272957..f3a2b99db6 100755 --- a/basis/compiler/tree/builder/builder-tests.factor +++ b/basis/compiler/tree/builder/builder-tests.factor @@ -4,24 +4,24 @@ compiler.tree stack-checker stack-checker.errors ; : inline-recursive ( -- ) inline-recursive ; inline recursive -[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? ] unit-test +[ t ] [ \ inline-recursive build-tree [ #recursive? ] any? ] unit-test : bad-recursion-1 ( a -- b ) dup [ drop bad-recursion-1 5 ] [ ] if ; -[ \ bad-recursion-1 build-tree-from-word ] [ inference-error? ] must-fail-with +[ \ bad-recursion-1 build-tree ] [ inference-error? ] must-fail-with FORGET: bad-recursion-1 : bad-recursion-2 ( obj -- obj ) dup [ dup first swap second bad-recursion-2 ] [ ] if ; -[ \ bad-recursion-2 build-tree-from-word ] [ inference-error? ] must-fail-with +[ \ bad-recursion-2 build-tree ] [ inference-error? ] must-fail-with FORGET: bad-recursion-2 : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; -[ \ bad-bin build-tree-from-word ] [ inference-error? ] must-fail-with +[ \ bad-bin build-tree ] [ inference-error? ] must-fail-with FORGET: bad-bin diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 05e6c5a14f..7a9877a406 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry accessors quotations kernel sequences namespaces +USING: fry locals accessors quotations kernel sequences namespaces assocs words arrays vectors hints combinators continuations effects compiler.tree stack-checker @@ -11,53 +11,55 @@ stack-checker.backend stack-checker.recursive-state ; IN: compiler.tree.builder -: with-tree-builder ( quot -- nodes ) - '[ V{ } clone stack-visitor set @ ] - with-infer nip ; inline +vector \ meta-d set ] - [ f initial-recursive-state infer-quot ] bi* - ] with-tree-builder - unclip-last in-d>> - ] [ 3drop f f ] recover ; - -: build-sub-tree ( #call quot -- nodes/f ) - [ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with - { - { [ over not ] [ 3drop f ] } - { [ over ends-with-terminate? ] [ drop swap [ f swap #push ] map append ] } - [ rot #copy suffix ] - } cond ; +M: callable (build-tree) f initial-recursive-state infer-quot ; : check-no-compile ( word -- ) dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ; -: (build-tree-from-word) ( word -- ) - dup initial-recursive-state recursive-state set - dup [ "inline" word-prop ] [ "recursive" word-prop ] bi and - [ 1quotation ] [ specialized-def ] if - infer-quot-here ; - : check-effect ( word effect -- ) swap required-stack-effect 2dup effect<= [ 2drop ] [ effect-error ] if ; -: finish-word ( word -- ) - current-effect check-effect ; +: inline-recursive? ( word -- ? ) + [ "inline" word-prop ] [ "recursive" word-prop ] bi and ; -: build-tree-from-word ( word -- nodes ) - [ +: word-body ( word -- quot ) + dup inline-recursive? [ 1quotation ] [ specialized-def ] if ; + +M: word (build-tree) + { + [ initial-recursive-state recursive-state set ] [ check-no-compile ] - [ (build-tree-from-word) ] - [ finish-word ] - tri - ] with-tree-builder ; + [ word-body infer-quot-here ] + [ current-effect check-effect ] + } cleave ; + +: build-tree-with ( in-stack word/quot -- nodes ) + [ + V{ } clone stack-visitor set + [ [ >vector \ meta-d set ] [ length d-in set ] bi ] + [ (build-tree) ] + bi* + ] with-infer nip ; + +PRIVATE> + +: build-tree ( word/quot -- nodes ) + [ f ] dip build-tree-with ; + +:: build-sub-tree ( #call word/quot -- nodes/f ) + [ + #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d + { + { [ dup not ] [ ] } + { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] } + [ in-d #call out-d>> #copy suffix ] + } cond + ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ; : contains-breakpoints? ( word -- ? ) def>> [ word? ] filter [ "break?" word-prop ] any? ; diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index e25f152aef..718def367d 100755 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -144,13 +144,15 @@ M: #terminate check-stack-flow* SYMBOL: branch-out -: check-branch ( nodes -- stack ) +: check-branch ( nodes -- datastack ) [ datastack [ clone ] change - V{ } clone retainstack set - (check-stack-flow) - terminated? get [ assert-retainstack-empty ] unless - terminated? get f datastack get ? + retainstack [ clone ] change + retainstack get clone [ (check-stack-flow) ] dip + terminated? get [ drop f ] [ + retainstack get assert= + datastack get + ] if ] with-scope ; M: #branch check-stack-flow* diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 8e102e0ea3..b1dc04082e 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -142,8 +142,7 @@ SYMBOL: node-count : make-report ( word/quot -- assoc ) [ - dup word? [ build-tree-from-word ] [ build-tree ] if - optimize-tree + build-tree optimize-tree H{ } clone words-called set H{ } clone generics-called set diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index fe3c7acb92..daa8f072ca 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -29,6 +29,7 @@ SYMBOL: check-optimizer? normalize propagate cleanup + ?check dup run-escape-analysis? [ escape-analysis unbox-tuples diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 8e9476a7ed..aa66b2f6d7 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -28,12 +28,10 @@ SYMBOL: node-count SYMBOL: inlining-count ! Splicing nodes -GENERIC: splicing-nodes ( #call word/quot/f -- nodes/f ) - -M: word splicing-nodes +: splicing-call ( #call word -- nodes ) [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; -M: callable splicing-nodes +: splicing-body ( #call quot/word -- nodes/f ) build-sub-tree dup [ analyze-recursive normalize ] when ; ! Dispatch elimination @@ -43,6 +41,12 @@ M: callable splicing-nodes : propagate-body ( #call -- ? ) body>> (propagate) t ; +GENERIC: splicing-nodes ( #call word/quot -- nodes/f ) + +M: word splicing-nodes splicing-call ; + +M: callable splicing-nodes splicing-body ; + : eliminate-dispatch ( #call class/f word/quot/f -- ? ) dup [ [ >>class ] dip @@ -168,7 +172,7 @@ SYMBOL: history :: inline-word ( #call word -- ? ) word history get memq? [ f ] [ - #call word specialized-def splicing-nodes [ + #call word splicing-body [ [ word remember-inlining [ ] [ count-nodes ] [ (propagate) ] tri diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index ed9c01b06c..182de28cd9 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -84,11 +84,8 @@ M: object apply-object push-literal ; meta-r empty? [ too-many->r ] unless ; : infer-quot-here ( quot -- ) - meta-r [ - V{ } clone \ meta-r set - [ apply-object terminated? get not ] all? - [ commit-literals check->r ] [ literals get delete-all ] if - ] dip \ meta-r set ; + [ apply-object terminated? get not ] all? + [ commit-literals ] [ literals get delete-all ] if ; : infer-quot ( quot rstate -- ) recursive-state get [ @@ -116,10 +113,14 @@ M: object apply-object push-literal ; ] if ; : infer->r ( n -- ) - consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ; + terminated? get [ drop ] [ + consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi + ] if ; : infer-r> ( n -- ) - consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ; + terminated? get [ drop ] [ + consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi + ] if ; : (consume/produce) ( effect -- inputs outputs ) [ in>> length consume-d ] [ out>> length produce-d ] bi ; @@ -130,6 +131,7 @@ M: object apply-object push-literal ; bi ; inline : end-infer ( -- ) + terminated? get [ check->r ] unless meta-d clone #return, ; : required-stack-effect ( word -- effect ) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 37059c19d0..80721d0b0e 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -221,6 +221,10 @@ M: object infer-call* [ t "no-compile" set-word-prop ] bi ] each +! Exceptions to the above +\ curry f "no-compile" set-word-prop +\ compose f "no-compile" set-word-prop + M\ quotation call t "no-compile" set-word-prop M\ curry call t "no-compile" set-word-prop M\ compose call t "no-compile" set-word-prop diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 814f528cdb..9f5d0a2213 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -299,7 +299,7 @@ ERROR: custom-error ; [ custom-error inference-error ] infer ] unit-test -[ T{ effect f 1 2 t } ] [ +[ T{ effect f 1 1 t } ] [ [ dup [ 3 throw ] dip ] infer ] unit-test diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index a76d302a7e..9b87854b69 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -42,6 +42,7 @@ SYMBOL: literals : init-inference ( -- ) terminated? off V{ } clone \ meta-d set + V{ } clone \ meta-r set V{ } clone literals set 0 d-in set ; From 8e1499ab79ec148c10e3c9e062a521d020fb8f99 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 23:02:11 -0500 Subject: [PATCH 82/98] Load tools.errors in stage2 so that bootstrap errors print correctly --- basis/bootstrap/stage2.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index d6c1876d6a..4eb2a1db91 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -78,6 +78,8 @@ SYMBOL: bootstrap-time "stage2: deployment mode" print ] [ "listener" require + "debugger" require + "tools.errors" require "none" require ] if From 399de5137d74a365e5594a064fab0a1217bc1efb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 23:02:20 -0500 Subject: [PATCH 83/98] help.markup: { $maybe "foo" } now works --- basis/help/markup/markup.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index f22560a4ce..04b6d90883 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -251,7 +251,7 @@ M: word ($instance) dup name>> a/an write bl ($link) ; M: string ($instance) - dup a/an write bl $snippet ; + write ; M: f ($instance) drop { f } $link ; From 28b9e474dd0e4328af6831588cf74f57722e9418 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 23:18:19 -0500 Subject: [PATCH 84/98] Set more no-compile word props --- basis/stack-checker/known-words/known-words.factor | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 80721d0b0e..eade33e52b 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -225,10 +225,16 @@ M: object infer-call* \ curry f "no-compile" set-word-prop \ compose f "no-compile" set-word-prop -M\ quotation call t "no-compile" set-word-prop -M\ curry call t "no-compile" set-word-prop -M\ compose call t "no-compile" set-word-prop -M\ word execute t "no-compile" set-word-prop +! More words not to compile +\ call t "no-compile" set-word-prop +\ call subwords [ t "no-compile" set-word-prop ] each + +\ execute t "no-compile" set-word-prop +\ execute subwords [ t "no-compile" set-word-prop ] each + +\ effective-method t "no-compile" set-word-prop +\ effective-method subwords [ t "no-compile" set-word-prop ] each + \ clear t "no-compile" set-word-prop : non-inline-word ( word -- ) From 487b92074c13b1918a5c24f3bbd572f8fc57afb4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 23:19:13 -0500 Subject: [PATCH 85/98] Remove method-declaration stuff from generic.standard since hints accomplishes the same thing --- core/generic/standard/standard.factor | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 5dbc0d17a1..148e16bd33 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -13,13 +13,7 @@ GENERIC: dispatch# ( word -- n ) M: generic dispatch# "combination" word-prop dispatch# ; -GENERIC: method-declaration ( class generic -- quot ) - -M: generic method-declaration - "combination" word-prop method-declaration ; - -M: quotation engine>quot - assumed get generic get method-declaration prepend ; +M: quotation engine>quot ; ERROR: no-method object generic ; @@ -122,9 +116,6 @@ M: standard-combination perform-combination M: standard-combination dispatch# #>> ; -M: standard-combination method-declaration - dispatch# object swap prefix [ declare ] curry [ ] like ; - M: standard-combination next-method-quot* [ single-next-method-quot @@ -151,8 +142,6 @@ PREDICATE: hook-generic < generic M: hook-combination dispatch# drop 0 ; -M: hook-combination method-declaration 2drop [ ] ; - M: hook-generic extra-values drop 1 ; M: hook-generic effective-method From 5d64766e4c89e0518e1ab1d515e5b196d0e1dc9b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 23:19:46 -0500 Subject: [PATCH 86/98] X11.windows: fix bug with radeonhd driver (reported by Chris Double) --- basis/x11/windows/windows.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index 87a212bd8e..37da51e9b8 100644 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -6,7 +6,7 @@ arrays fry ; IN: x11.windows : create-window-mask ( -- n ) - { CWColormap CWEventMask } flags ; + { CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ; : create-colormap ( visinfo -- colormap ) [ dpy get root get ] dip XVisualInfo-visual AllocNone From a3c0dd44a167eac164bd28dc7c9b71b3ad9ef92d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 00:15:48 -0500 Subject: [PATCH 87/98] Revert "Remove method-declaration stuff from generic.standard since hints accomplishes the same thing" This reverts commit 487b92074c13b1918a5c24f3bbd572f8fc57afb4. --- core/generic/standard/standard.factor | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 148e16bd33..5dbc0d17a1 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -13,7 +13,13 @@ GENERIC: dispatch# ( word -- n ) M: generic dispatch# "combination" word-prop dispatch# ; -M: quotation engine>quot ; +GENERIC: method-declaration ( class generic -- quot ) + +M: generic method-declaration + "combination" word-prop method-declaration ; + +M: quotation engine>quot + assumed get generic get method-declaration prepend ; ERROR: no-method object generic ; @@ -116,6 +122,9 @@ M: standard-combination perform-combination M: standard-combination dispatch# #>> ; +M: standard-combination method-declaration + dispatch# object swap prefix [ declare ] curry [ ] like ; + M: standard-combination next-method-quot* [ single-next-method-quot @@ -142,6 +151,8 @@ PREDICATE: hook-generic < generic M: hook-combination dispatch# drop 0 ; +M: hook-combination method-declaration 2drop [ ] ; + M: hook-generic extra-values drop 1 ; M: hook-generic effective-method From dea3987ca52699b64b0a08bd7b4e719b5f7b5356 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 00:44:06 -0500 Subject: [PATCH 88/98] Silly workaround for performance regression --- basis/compiler/tree/builder/builder.factor | 5 +++++ basis/hints/hints.factor | 21 +++++++++++++-------- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 7a9877a406..3f00a3bb68 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -52,6 +52,11 @@ PRIVATE> [ f ] dip build-tree-with ; :: build-sub-tree ( #call word/quot -- nodes/f ) + #! We don't want methods on mixins to have a declaration for that mixin. + #! This slows down compiler.tree.propagation.inlining since then every + #! inlined usage of a method has an inline-dependency on the mixin, and + #! not the more specific type at the call site. + specialize-method? off [ #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d { diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index ed55c1c332..d445bf72ad 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: parser words definitions kernel sequences assocs arrays kernel.private fry combinators accessors vectors strings sbufs -byte-arrays byte-vectors io.binary io.streams.string splitting -math math.parser generic generic.standard generic.standard.engines classes -hashtables ; +byte-arrays byte-vectors io.binary io.streams.string splitting math +math.parser generic generic.standard generic.standard.engines classes +hashtables namespaces ; IN: hints GENERIC: specializer-predicate ( spec -- quot ) @@ -37,13 +37,18 @@ M: object specializer-declaration class ; : specialize-quot ( quot specializer -- quot' ) specializer-cases alist>quot ; -: method-declaration ( method -- quot ) - [ "method-generic" word-prop dispatch# object ] - [ "method-class" word-prop ] - bi prefix ; +! compiler.tree.propagation.inlining sets this to f +SYMBOL: specialize-method? + +t specialize-method? set-global : specialize-method ( quot method -- quot' ) - [ method-declaration '[ _ declare ] prepend ] + [ + specialize-method? get [ + [ "method-class" word-prop ] [ "method-generic" word-prop ] bi + method-declaration prepend + ] [ drop ] if + ] [ "method-generic" word-prop "specializer" word-prop ] bi [ specialize-quot ] when* ; From 48e70b65fae81c633f8da9abeac3d8f478d7beb3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 04:20:38 -0500 Subject: [PATCH 89/98] Move cross-referencing stuff to tools.crossref since compiler doesn't depend on it anymore, and compute cross-referencing index as needed; reduces image size by ~4Mb --- basis/bootstrap/stage2.factor | 9 -- basis/help/crossref/crossref-docs.factor | 5 - basis/help/crossref/crossref.factor | 10 +- basis/help/help.factor | 6 +- .../tools/continuations/continuations.factor | 2 +- basis/tools/crossref/crossref-docs.factor | 46 +++++++- basis/tools/crossref/crossref-tests.factor | 37 ++++++ basis/tools/crossref/crossref.factor | 110 +++++++++++++++++- basis/tools/profiler/profiler-docs.factor | 4 +- basis/tools/profiler/profiler.factor | 2 +- basis/tools/vocabs/vocabs.factor | 21 ---- basis/ui/tools/browser/popups/popups.factor | 2 +- core/bootstrap/primitives.factor | 2 - core/classes/tuple/tuple-tests.factor | 2 - core/compiler/units/units-tests.factor | 4 +- core/compiler/units/units.factor | 2 +- core/definitions/definitions-docs.factor | 44 ------- core/definitions/definitions.factor | 28 +---- core/generic/generic-tests.factor | 60 +--------- core/generic/generic.factor | 8 -- .../standard/engines/tuple/tuple.factor | 2 - core/generic/standard/standard-tests.factor | 21 ---- core/parser/parser.factor | 2 +- core/source-files/source-files-docs.factor | 23 +--- core/source-files/source-files.factor | 34 ++---- core/words/words-docs.factor | 4 - core/words/words-tests.factor | 71 ----------- core/words/words.factor | 39 +------ 28 files changed, 219 insertions(+), 381 deletions(-) diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 4eb2a1db91..4d566a288d 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -16,13 +16,6 @@ SYMBOL: bootstrap-time vm file-name os windows? [ "." split1-last drop ] when ".image" append resource-path ; -: do-crossref ( -- ) - "Cross-referencing..." print flush - H{ } clone crossref set-global - xref-words - xref-generics - xref-sources ; - : load-components ( -- ) "include" "exclude" [ get-global " " split harvest ] bi@ @@ -68,8 +61,6 @@ SYMBOL: bootstrap-time (command-line) parse-command-line - do-crossref - ! Set dll paths os wince? [ "windows.ce" require ] when os winnt? [ "windows.nt" require ] when diff --git a/basis/help/crossref/crossref-docs.factor b/basis/help/crossref/crossref-docs.factor index ae227fde89..7f243ec764 100644 --- a/basis/help/crossref/crossref-docs.factor +++ b/basis/help/crossref/crossref-docs.factor @@ -17,8 +17,3 @@ HELP: xref-article { $values { "topic" "an article name or a word" } } { $description "Sets the " { $link article-parent } " of each child of this article." } $low-level-note ; - -HELP: unxref-article -{ $values { "topic" "an article name or a word" } } -{ $description "Clears the " { $link article-parent } " of each child of this article." } -$low-level-note ; diff --git a/basis/help/crossref/crossref.factor b/basis/help/crossref/crossref.factor index b791a4b124..46f9561605 100644 --- a/basis/help/crossref/crossref.factor +++ b/basis/help/crossref/crossref.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic assocs math fry io kernel namespaces prettyprint prettyprint.sections @@ -12,9 +12,6 @@ IN: help.crossref : article-children ( topic -- seq ) { $subsection } article-links ; -M: link uses - { $subsection $link $see-also } article-links ; - : help-path ( topic -- seq ) [ article-parent ] follow rest ; @@ -22,10 +19,7 @@ M: link uses article-children [ set-article-parent ] with each ; : xref-article ( topic -- ) - dup >link xref dup set-article-parents ; - -: unxref-article ( topic -- ) - >link unxref ; + dup set-article-parents ; : prev/next ( obj seq n -- obj' ) [ [ index dup ] keep ] dip swap diff --git a/basis/help/help.factor b/basis/help/help.factor index d20e06b6c6..956bc220e1 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -156,10 +156,7 @@ help-hook [ [ print-topic ] ] initialize error get (:help) ; : remove-article ( name -- ) - dup articles get key? [ - dup unxref-article - dup articles get delete-at - ] when drop ; + articles get delete-at ; : add-article ( article name -- ) [ remove-article ] keep @@ -167,7 +164,6 @@ help-hook [ [ print-topic ] ] initialize xref-article ; : remove-word-help ( word -- ) - dup word-help [ dup unxref-article ] when f "help" set-word-prop ; : set-word-help ( content word -- ) diff --git a/basis/tools/continuations/continuations.factor b/basis/tools/continuations/continuations.factor index 3e28c5925f..1ac4557ec4 100644 --- a/basis/tools/continuations/continuations.factor +++ b/basis/tools/continuations/continuations.factor @@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words sequences.private assocs models models.arrow arrays accessors -generic generic.standard definitions make sbufs ; +generic generic.standard definitions make sbufs tools.crossref ; IN: tools.continuations > "integer=>generic-forget-test-1" = ] any? +] unit-test + +[ ] [ + [ \ generic-forget-test-1 forget ] with-compilation-unit +] unit-test + +[ f ] [ + \ / usage [ word? ] filter + [ name>> "integer=>generic-forget-test-1" = ] any? +] unit-test + +GENERIC: generic-forget-test-2 ( a b -- c ) + +M: sequence generic-forget-test-2 = ; + +[ t ] [ + \ = usage [ word? ] filter + [ name>> "sequence=>generic-forget-test-2" = ] any? +] unit-test + +[ ] [ + [ M\ sequence generic-forget-test-2 forget ] with-compilation-unit +] unit-test + +[ f ] [ + \ = usage [ word? ] filter + [ name>> "sequence=>generic-forget-test-2" = ] any? +] unit-test \ No newline at end of file diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index 36ccaadc98..feaddc8194 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -1,9 +1,84 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs definitions io io.styles kernel prettyprint -sorting see ; +USING: words assocs definitions io io.pathnames io.styles kernel +prettyprint sorting see sets sequences arrays hashtables help.crossref +help.topics help.markup quotations accessors source-files namespaces +graphs vocabs generic generic.standard.engines.tuple threads +compiler.units init ; IN: tools.crossref +SYMBOL: crossref + +GENERIC: uses ( defspec -- seq ) + +alist ] dip seq-uses ; + +M: callable quot-uses seq-uses ; + +M: wrapper quot-uses [ wrapped>> ] dip quot-uses ; + +M: callable uses ( quot -- assoc ) + H{ } clone [ quot-uses ] keep keys ; + +M: word uses def>> uses ; + +M: link uses { $subsection $link $see-also } article-links ; + +M: pathname uses string>> source-file top-level-form>> uses ; + +GENERIC: crossref-def ( defspec -- ) + +M: object crossref-def + dup uses crossref get add-vertex ; + +M: word crossref-def + [ call-next-method ] [ subwords [ crossref-def ] each ] bi ; + +: build-crossref ( -- crossref ) + "Computing usage index... " write flush yield + H{ } clone crossref [ + all-words + source-files get keys [ ] map + [ [ crossref-def ] each ] bi@ + crossref get + ] with-variable + "done" print flush ; + +: get-crossref ( -- crossref ) + crossref global [ drop build-crossref ] cache ; + +GENERIC: irrelevant? ( defspec -- ? ) + +M: object irrelevant? drop f ; + +M: default-method irrelevant? drop t ; + +M: engine-word irrelevant? drop t ; + +PRIVATE> + +: usage ( defspec -- seq ) get-crossref at keys ; + +GENERIC: smart-usage ( defspec -- seq ) + +M: object smart-usage usage [ irrelevant? not ] filter ; + +M: method-body smart-usage "method-generic" word-prop smart-usage ; + +M: f smart-usage drop \ f smart-usage ; + : synopsis-alist ( definitions -- alist ) [ [ synopsis ] keep ] { } map>assoc ; @@ -15,3 +90,34 @@ IN: tools.crossref : usage. ( word -- ) smart-usage sorted-definitions. ; + +: vocab-xref ( vocab quot -- vocabs ) + [ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map + [ + [ [ word? ] [ generic? not ] bi and ] filter [ + dup method-body? + [ "method-generic" word-prop ] when + vocabulary>> + ] map + ] gather natural-sort remove sift ; inline + +: vocabs. ( seq -- ) + [ dup >vocab-link write-object nl ] each ; + +: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; + +: vocab-uses. ( vocab -- ) vocab-uses vocabs. ; + +: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ; + +: vocab-usage. ( vocab -- ) vocab-usage vocabs. ; + + \ No newline at end of file diff --git a/basis/tools/profiler/profiler-docs.factor b/basis/tools/profiler/profiler-docs.factor index baecbd71c1..efd2e164a3 100644 --- a/basis/tools/profiler/profiler-docs.factor +++ b/basis/tools/profiler/profiler-docs.factor @@ -1,5 +1,5 @@ -USING: tools.profiler.private tools.time help.markup help.syntax -quotations io strings words definitions ; +USING: tools.profiler.private tools.time tools.crossref +help.markup help.syntax quotations io strings words definitions ; IN: tools.profiler ARTICLE: "profiler-limitations" "Profiler limitations" diff --git a/basis/tools/profiler/profiler.factor b/basis/tools/profiler/profiler.factor index f4488136b2..219344db3b 100644 --- a/basis/tools/profiler/profiler.factor +++ b/basis/tools/profiler/profiler.factor @@ -3,7 +3,7 @@ USING: accessors words sequences math prettyprint kernel arrays io io.styles namespaces assocs kernel.private strings combinators sorting math.parser vocabs definitions tools.profiler.private -continuations generic compiler.units sets classes fry ; +tools.crossref continuations generic compiler.units sets classes fry ; IN: tools.profiler : profile ( quot -- ) diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index 66618ee23c..ba99a41eba 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -8,27 +8,6 @@ continuations compiler.errors init checksums checksums.crc32 sets accessors generic definitions words ; IN: tools.vocabs -: vocab-xref ( vocab quot -- vocabs ) - [ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map - [ - [ [ word? ] [ generic? not ] bi and ] filter [ - dup method-body? - [ "method-generic" word-prop ] when - vocabulary>> - ] map - ] gather natural-sort remove sift ; inline - -: vocabs. ( seq -- ) - [ dup >vocab-link write-object nl ] each ; - -: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; - -: vocab-uses. ( vocab -- ) vocab-uses vocabs. ; - -: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ; - -: vocab-usage. ( vocab -- ) vocab-usage vocabs. ; - : vocab-tests-file ( vocab -- path ) dup "-tests.factor" vocab-dir+ vocab-append-path dup [ dup exists? [ drop f ] unless ] [ drop f ] if ; diff --git a/basis/ui/tools/browser/popups/popups.factor b/basis/ui/tools/browser/popups/popups.factor index 91ac96e0f9..2cd90ab335 100644 --- a/basis/ui/tools/browser/popups/popups.factor +++ b/basis/ui/tools/browser/popups/popups.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs definitions fry help.topics kernel colors.constants math.rectangles models.arrow namespaces sequences -sorting definitions.icons ui.gadgets ui.gadgets.glass +sorting definitions.icons tools.crossref ui.gadgets ui.gadgets.glass ui.gadgets.labeled ui.gadgets.scrollers ui.gadgets.tables ui.gadgets.search-tables ui.gadgets.wrappers ui.gestures ui.operations ui.pens.solid ui.images ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 4466bd9bfe..1258da8a4d 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -12,8 +12,6 @@ IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush -crossref off - H{ } clone sub-primitives set "vocab:bootstrap/syntax.factor" parse-file diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 4b556396e2..c180807b0c 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -110,8 +110,6 @@ TUPLE: yo-momma ; [ ] [ \ yo-momma forget ] unit-test [ ] [ \ forget ] unit-test [ f ] [ \ yo-momma update-map get values memq? ] unit-test - - [ f ] [ \ yo-momma crossref get at ] unit-test ] with-compilation-unit TUPLE: loc-recording ; diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index 0b74f3a236..da2dce128f 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -36,7 +36,7 @@ IN: compiler.units.tests enable-compiler ] unit-test -! Notify observers even if compilation unit did nothing +! Check that we notify observers SINGLETON: observer observer add-definition-observer @@ -47,7 +47,7 @@ SYMBOL: counter M: observer definitions-changed 2drop global [ counter inc ] bind ; -[ ] with-compilation-unit +[ gensym [ ] (( -- )) define-declared ] with-compilation-unit [ 1 ] [ counter get-global ] unit-test diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 02a80c4d84..c84e8fa73e 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -144,7 +144,7 @@ GENERIC: definitions-changed ( assoc obj -- ) update-tuples process-forgotten-definitions modify-code-heap - updated-definitions notify-definition-observers + updated-definitions dup assoc-empty? [ drop ] [ notify-definition-observers ] if notify-error-observers ; : with-nested-compilation-unit ( quot -- ) diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index 9d49cf62c6..b1575cc1e4 100644 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -10,21 +10,11 @@ $nl { $subsection set-where } "Definitions can be removed:" { $subsection forget } -"Definitions can answer a sequence of definitions they directly depend on:" -{ $subsection uses } "Definitions must implement a few operations used for printing them in source form:" { $subsection definer } { $subsection definition } { $see-also "see" } ; -ARTICLE: "definition-crossref" "Definition cross referencing" -"A common cross-referencing system is used to track definition usages:" -{ $subsection crossref } -{ $subsection xref } -{ $subsection unxref } -{ $subsection delete-xref } -{ $subsection usage } ; - ARTICLE: "definition-checking" "Definition sanity checking" "When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } ". A warning message is printed if any other definitions still depend on the removed definitions." $nl @@ -69,7 +59,6 @@ $nl } "For every source file loaded into the system, a list of definitions is maintained. Pathname objects implement the definition protocol, acting over the definitions their source files contain. See " { $link "source-files" } " for details." { $subsection "definition-protocol" } -{ $subsection "definition-crossref" } { $subsection "definition-checking" } { $subsection "compilation-units" } "A parsing word to remove definitions:" @@ -96,36 +85,3 @@ HELP: forget-all { $values { "definitions" "a sequence of definition specifiers" } } { $description "Forgets every definition in a sequence." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } ; - -HELP: uses -{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } } -{ $description "Outputs a sequence of definitions directory called by the given definition." } -{ $notes "The sequence might include the definition itself, if it is a recursive word." } -{ $examples - "We can ask the " { $link sq } " word to produce a list of words it calls:" - { $unchecked-example "\ sq uses ." "{ dup * }" } -} ; - -HELP: crossref -{ $var-description "A graph whose vertices are definition specifiers and edges are usages. See " { $link "graphs" } "." } ; - -HELP: xref -{ $values { "defspec" "a definition specifier" } } -{ $description "Adds a vertex representing this definition, along with edges representing dependencies to the " { $link crossref } " graph." } -$low-level-note ; - -HELP: usage -{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } } -{ $description "Outputs a sequence of definitions that directly call the given definition." } -{ $notes "The sequence might include the definition itself, if it is a recursive word." } ; - -HELP: unxref -{ $values { "defspec" "a definition specifier" } } -{ $description "Remove edges leaving the vertex which represents the definition from the " { $link crossref } " graph." } -{ $notes "This word is called before a word is redefined." } ; - -HELP: delete-xref -{ $values { "defspec" "a definition specifier" } } -{ $description "Remove the vertex which represents the definition from the " { $link crossref } " graph." } -{ $notes "This word is called before a word is forgotten." } -{ $see-also forget } ; diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 1a26e45e87..5dc3808362 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences namespaces assocs graphs math math.order ; +USING: kernel sequences namespaces assocs math ; IN: definitions MIXIN: definition @@ -53,29 +53,3 @@ SYMBOL: forgotten-definitions GENERIC: definer ( defspec -- start end ) GENERIC: definition ( defspec -- seq ) - -SYMBOL: crossref - -GENERIC: uses ( defspec -- seq ) - -M: object uses drop f ; - -: xref ( defspec -- ) dup uses crossref get add-vertex ; - -: usage ( defspec -- seq ) crossref get at keys ; - -GENERIC: irrelevant? ( defspec -- ? ) - -M: object irrelevant? drop f ; - -GENERIC: smart-usage ( defspec -- seq ) - -M: f smart-usage drop \ f smart-usage ; - -M: object smart-usage usage [ irrelevant? not ] filter ; - -: unxref ( defspec -- ) - dup uses crossref get remove-vertex ; - -: delete-xref ( defspec -- ) - dup unxref crossref get delete-at ; diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 37f5cf40ae..e7ae583aa6 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -133,69 +133,19 @@ M: f tag-and-f 4 ; [ 3.4 3 ] [ 3.4 tag-and-f ] unit-test ! Issues with forget -GENERIC: generic-forget-test-1 ( a b -- c ) +GENERIC: generic-forget-test ( a -- b ) -M: integer generic-forget-test-1 / ; +M: f generic-forget-test ; -[ t ] [ - \ / usage [ word? ] filter - [ name>> "integer=>generic-forget-test-1" = ] any? -] unit-test - -[ ] [ - [ \ generic-forget-test-1 forget ] with-compilation-unit -] unit-test - -[ f ] [ - \ / usage [ word? ] filter - [ name>> "integer=>generic-forget-test-1" = ] any? -] unit-test - -GENERIC: generic-forget-test-2 ( a b -- c ) - -M: sequence generic-forget-test-2 = ; - -[ t ] [ - \ = usage [ word? ] filter - [ name>> "sequence=>generic-forget-test-2" = ] any? -] unit-test - -[ ] [ - [ M\ sequence generic-forget-test-2 forget ] with-compilation-unit -] unit-test - -[ f ] [ - \ = usage [ word? ] filter - [ name>> "sequence=>generic-forget-test-2" = ] any? -] unit-test - -GENERIC: generic-forget-test-3 ( a -- b ) - -M: f generic-forget-test-3 ; - -[ ] [ \ f \ generic-forget-test-3 method "m" set ] unit-test +[ ] [ \ f \ generic-forget-test method "m" set ] unit-test [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test -[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval( -- ) ] unit-test +[ ] [ "IN: generic.tests M: f generic-forget-test ;" eval( -- ) ] unit-test [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test -[ f ] [ f generic-forget-test-3 ] unit-test - -: a-word ( -- ) ; - -GENERIC: a-generic ( a -- b ) - -M: integer a-generic a-word ; - -[ ] [ \ integer \ a-generic method "m" set ] unit-test - -[ t ] [ "m" get \ a-word usage memq? ] unit-test - -[ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval( -- ) ] unit-test - -[ f ] [ "m" get \ a-word usage memq? ] unit-test +[ f ] [ f generic-forget-test ] unit-test ! erg's regression [ ] [ diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 7fdb339069..965be91642 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -123,8 +123,6 @@ M: method-body crossref? PREDICATE: default-method < word "default" word-prop ; -M: default-method irrelevant? drop t ; - : ( generic combination -- method ) [ drop object bootstrap-word swap ] [ make-default-method ] 2bi [ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ; @@ -155,9 +153,6 @@ M: method-body forget* [ call-next-method ] bi ] if ; -M: method-body smart-usage - "method-generic" word-prop smart-usage ; - M: sequence update-methods ( class seq -- ) implementors [ [ changed-generic ] [ remake-generic drop ] 2bi @@ -192,6 +187,3 @@ M: generic forget* M: class forget-methods [ implementors ] [ [ swap method ] curry ] bi map forget-all ; - -: xref-generics ( -- ) - all-words [ subwords [ xref ] each ] each ; diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 7e91adfaa1..a0711af095 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -86,8 +86,6 @@ M: engine-word where "tuple-dispatch-generic" word-prop where ; M: engine-word crossref? "forgotten" word-prop not ; -M: engine-word irrelevant? drop t ; - : remember-engine ( word -- ) generic get "engines" word-prop push ; diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index 420dd16991..58007f795f 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -280,27 +280,6 @@ M: growable call-next-hooker call-next-method "growable " prepend ; V{ } my-var [ call-next-hooker ] with-variable ] unit-test -! Cross-referencing with generic words -TUPLE: xref-tuple-1 ; -TUPLE: xref-tuple-2 < xref-tuple-1 ; - -: (xref-test) ( obj -- ) drop ; - -GENERIC: xref-test ( obj -- ) - -M: xref-tuple-1 xref-test (xref-test) ; -M: xref-tuple-2 xref-test (xref-test) ; - -[ t ] [ - \ xref-test - \ xref-tuple-1 \ xref-test method [ usage unique ] closure key? -] unit-test - -[ t ] [ - \ xref-test - \ xref-tuple-2 \ xref-test method [ usage unique ] closure key? -] unit-test - [ t ] [ { } \ nth effective-method nip \ sequence \ nth method eq? ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 9876818d26..7908f40cbe 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -264,7 +264,7 @@ print-use-hook [ [ ] ] initialize : finish-parsing ( lines quot -- ) file get - [ record-form ] + [ record-top-level-form ] [ record-definitions ] [ record-checksum ] tri ; diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor index 2c9e2172cc..eb1284cd25 100644 --- a/core/source-files/source-files-docs.factor +++ b/core/source-files/source-files-docs.factor @@ -11,9 +11,7 @@ $nl { $subsection source-file } "Words intended for the parser:" { $subsection record-checksum } -{ $subsection record-form } -{ $subsection xref-source } -{ $subsection unxref-source } +{ $subsection record-definitions } "Removing a source file from the database:" { $subsection forget-source } "Updating the database:" @@ -42,25 +40,6 @@ HELP: record-checksum { $description "Records the CRC32 checksm of the source file's contents." } $low-level-note ; -HELP: xref-source -{ $values { "source-file" source-file } } -{ $description "Adds the source file to the " { $link crossref } " graph enabling words to find source files which reference them in their top level forms." } -$low-level-note ; - -HELP: unxref-source -{ $values { "source-file" source-file } } -{ $description "Removes the source file from the " { $link crossref } " graph." } -$low-level-note ; - -HELP: xref-sources -{ $description "Adds all loaded source files to the " { $link crossref } " graph. This is done during bootstrap." } -$low-level-note ; - -HELP: record-form -{ $values { "quot" quotation } { "source-file" source-file } } -{ $description "Records usage information for a source file's top level form." } -$low-level-note ; - HELP: reset-checksums { $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "tools.vocabs" } "." } ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 6884a10d03..558018a147 100644 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic assocs kernel math namespaces sequences strings vectors words quotations io io.files @@ -11,29 +11,16 @@ SYMBOL: source-files TUPLE: source-file path +top-level-form checksum -uses definitions ; +definitions ; + +: record-top-level-form ( quot file -- ) + (>>top-level-form) H{ } notify-definition-observers ; : record-checksum ( lines source-file -- ) [ crc32 checksum-lines ] dip (>>checksum) ; -: (xref-source) ( source-file -- pathname uses ) - [ path>> ] - [ uses>> [ crossref? ] filter ] bi ; - -: xref-source ( source-file -- ) - (xref-source) crossref get add-vertex ; - -: unxref-source ( source-file -- ) - (xref-source) crossref get remove-vertex ; - -: xref-sources ( -- ) - source-files get [ nip xref-source ] assoc-each ; - -: record-form ( quot source-file -- ) - [ quot-uses keys ] dip - [ unxref-source ] [ (>>uses) ] [ xref-source ] tri ; - : record-definitions ( file -- ) new-definitions get >>definitions drop ; @@ -58,13 +45,8 @@ ERROR: invalid-source-file-path path ; M: pathname where string>> 1 2array ; : forget-source ( path -- ) - [ - source-file - [ unxref-source ] - [ definitions>> [ keys forget-all ] each ] bi - ] - [ source-files get delete-at ] - bi ; + source-files get delete-at* + [ definitions>> [ keys forget-all ] each ] [ drop ] if ; M: pathname forget* string>> forget-source ; diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 4bed65374c..c1b8c0c229 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -290,10 +290,6 @@ HELP: define-temp "This word must be called from inside " { $link with-compilation-unit } "." } ; -HELP: quot-uses -{ $values { "quot" quotation } { "assoc" "an assoc with words as keys" } } -{ $description "Outputs a set of words referenced by the quotation and any quotations it contains." } ; - HELP: delimiter? { $values { "obj" object } { "?" "a boolean" } } { $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." } diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 3ba5e1f693..0ecf7b65f0 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -63,52 +63,6 @@ FORGET: forgotten FORGET: another-forgotten : another-forgotten ( -- ) ; -! I forgot remove-crossref calls! -: fee ( -- ) ; -: foe ( -- ) fee ; -: fie ( -- ) foe ; - -[ t ] [ \ fee usage [ word? ] filter empty? ] unit-test -[ t ] [ \ foe usage empty? ] unit-test -[ f ] [ \ foe crossref get key? ] unit-test - -FORGET: foe - -! xref should not retain references to gensyms -[ ] [ - [ gensym [ * ] define ] with-compilation-unit -] unit-test - -[ t ] [ - \ * usage [ word? ] filter [ crossref? ] all? -] unit-test - -DEFER: calls-a-gensym -[ ] [ - [ - \ calls-a-gensym - gensym dup "x" set 1quotation - (( x -- x )) define-declared - ] with-compilation-unit -] unit-test - -[ f ] [ "x" get crossref get at ] unit-test - -! more xref buggery -[ f ] [ - GENERIC: xyzzle ( x -- x ) - : a ( -- ) ; \ a - M: integer xyzzle a ; - FORGET: a - M: object xyzzle ; - crossref get at -] unit-test - -! regression -GENERIC: freakish ( x -- y ) -: bar ( x -- y ) freakish ; -M: array freakish ; -[ t ] [ \ bar \ freakish usage member? ] unit-test DEFER: x [ x ] [ undefined? ] must-fail-with @@ -122,26 +76,6 @@ DEFER: x [ ] [ "IN: words.tests : test-last ( -- ) ;" eval( -- ) ] unit-test [ "test-last" ] [ word name>> ] unit-test -! regression -SYMBOL: quot-uses-a -SYMBOL: quot-uses-b - -[ ] [ - [ - quot-uses-a [ 2 3 + ] define - ] with-compilation-unit -] unit-test - -[ { + } ] [ \ quot-uses-a uses ] unit-test - -[ ] [ - [ - quot-uses-b 2 [ 3 + ] curry define - ] with-compilation-unit -] unit-test - -[ { + } ] [ \ quot-uses-b uses ] unit-test - "undef-test" "words.tests" lookup [ [ forget ] with-compilation-unit ] when* @@ -191,8 +125,3 @@ SYMBOL: quot-uses-b keys [ "forgotten" word-prop ] any? ] filter ] unit-test - -[ { } ] [ - crossref get keys - [ word? ] filter [ "forgotten" word-prop ] filter -] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index 1a2317997a..eb0599db78 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -62,33 +62,7 @@ SYMBOL: bootstrapping? GENERIC: crossref? ( word -- ? ) M: word crossref? - dup "forgotten" word-prop [ - drop f - ] [ - vocabulary>> >boolean - ] if ; - -GENERIC# (quot-uses) 1 ( obj assoc -- ) - -M: object (quot-uses) 2drop ; - -M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ; - -: seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ; - -M: array (quot-uses) seq-uses ; - -M: hashtable (quot-uses) [ >alist ] dip seq-uses ; - -M: callable (quot-uses) seq-uses ; - -M: wrapper (quot-uses) [ wrapped>> ] dip (quot-uses) ; - -: quot-uses ( quot -- assoc ) - global [ H{ } clone [ (quot-uses) ] keep ] bind ; - -M: word uses ( word -- seq ) - def>> quot-uses keys ; + dup "forgotten" word-prop [ drop f ] [ vocabulary>> >boolean ] if ; SYMBOL: compiled-crossref @@ -132,11 +106,7 @@ GENERIC: subwords ( word -- seq ) M: word subwords drop f ; : define ( word def -- ) - [ ] like - over unxref - over changed-definition - >>def - dup crossref? [ dup xref ] when drop ; + over changed-definition [ ] like >>def drop ; : changed-effect ( word -- ) [ dup changed-effects get set-in-unit ] @@ -228,10 +198,9 @@ M: word set-where swap "loc" set-word-prop ; M: word forget* dup "forgotten" word-prop [ drop ] [ - [ delete-xref ] [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ] [ t "forgotten" set-word-prop ] - tri + bi ] if ; M: word hashcode* @@ -239,6 +208,4 @@ M: word hashcode* M: word literalize ; -: xref-words ( -- ) all-words [ xref ] each ; - INSTANCE: word definition \ No newline at end of file From 20ca578ed15fc872f10ef1bf774a929e5210d486 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 04:21:15 -0500 Subject: [PATCH 90/98] stack-checker.transforms: fix tests --- basis/stack-checker/transforms/transforms-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index 126f6a9648..fe0fa08356 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -3,10 +3,10 @@ USING: sequences stack-checker.transforms tools.test math kernel quotations stack-checker stack-checker.errors accessors combinators words arrays classes classes.tuple ; -: compose-n-quot ( word n -- quot' ) >quotation ; -: compose-n ( quot n -- ) compose-n-quot call ; +: compose-n ( quot n -- ) "OOPS" throw ; << +: compose-n-quot ( word n -- quot' ) >quotation ; \ compose-n [ compose-n-quot ] 2 define-transform \ compose-n t "no-compile" set-word-prop >> From 65532de7de4118189290b15e80fd125658bf6e2d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 04:23:26 -0500 Subject: [PATCH 91/98] editors.emacs.windows: Add meta-data --- basis/editors/emacs/windows/authors.txt | 2 +- basis/editors/emacs/windows/tags.txt | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 basis/editors/emacs/windows/tags.txt diff --git a/basis/editors/emacs/windows/authors.txt b/basis/editors/emacs/windows/authors.txt index 7c1b2f2279..1901f27a24 100755 --- a/basis/editors/emacs/windows/authors.txt +++ b/basis/editors/emacs/windows/authors.txt @@ -1 +1 @@ -Doug Coleman +Slava Pestov diff --git a/basis/editors/emacs/windows/tags.txt b/basis/editors/emacs/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/emacs/windows/tags.txt @@ -0,0 +1 @@ +unportable From 3783d8513f9ce57e50a134bbf791aa10c2feac16 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 04:41:03 -0500 Subject: [PATCH 92/98] tools.deploy.shaker: fix --- basis/tools/deploy/shaker/shaker.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 0d7d8fd7c6..e23e1b092d 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -264,7 +264,6 @@ IN: tools.deploy.shaker compiler-impl compiler.errors:compiler-errors definition-observers - definitions:crossref interactive-vocabs layouts:num-tags layouts:num-types From caf6f280eabeb918676870372f441dc4c3649d3b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 04:46:47 -0500 Subject: [PATCH 93/98] annotations: update for usage being moved to tools.crossref --- extra/annotations/annotations-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/annotations/annotations-docs.factor b/extra/annotations/annotations-docs.factor index 1bece9d4fb..8685d954e8 100644 --- a/extra/annotations/annotations-docs.factor +++ b/extra/annotations/annotations-docs.factor @@ -1,6 +1,6 @@ USING: accessors arrays combinators definitions generalizations help help.markup help.topics kernel sequences sorting vocabs -words combinators.smart ; +words combinators.smart tools.crossref ; IN: annotations Date: Wed, 22 Apr 2009 06:50:09 -0500 Subject: [PATCH 94/98] Move multi-methods, and vocabs that depend on them (dns, shell, newfx). Multi methods won't be in Factor 1.0 and I don't want to keep maintaining this feature --- {extra => unmaintained}/boolean-expr/authors.txt | 0 {extra => unmaintained}/boolean-expr/boolean-expr.factor | 0 {extra => unmaintained}/boolean-expr/summary.txt | 0 {extra => unmaintained}/boolean-expr/tags.txt | 0 {extra => unmaintained}/dns/cache/nx/nx.factor | 0 {extra => unmaintained}/dns/cache/rr/rr.factor | 0 {extra => unmaintained}/dns/dns.factor | 0 {extra => unmaintained}/dns/forwarding/forwarding.factor | 0 {extra => unmaintained}/dns/misc/misc.factor | 0 {extra => unmaintained}/dns/resolver/resolver.factor | 0 {extra => unmaintained}/dns/server/server.factor | 0 {extra => unmaintained}/dns/stub/stub.factor | 0 {extra => unmaintained}/dns/util/util.factor | 0 {extra => unmaintained}/multi-methods/authors.txt | 0 {extra => unmaintained}/multi-methods/multi-methods.factor | 0 {extra => unmaintained}/multi-methods/summary.txt | 0 {extra => unmaintained}/multi-methods/tags.txt | 0 {extra => unmaintained}/multi-methods/tests/canonicalize.factor | 0 {extra => unmaintained}/multi-methods/tests/definitions.factor | 0 {extra => unmaintained}/multi-methods/tests/legacy.factor | 0 {extra => unmaintained}/multi-methods/tests/syntax.factor | 0 .../multi-methods/tests/topological-sort.factor | 0 {extra => unmaintained}/shell/parser/parser.factor | 0 {extra => unmaintained}/shell/shell.factor | 0 24 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/boolean-expr/authors.txt (100%) rename {extra => unmaintained}/boolean-expr/boolean-expr.factor (100%) rename {extra => unmaintained}/boolean-expr/summary.txt (100%) rename {extra => unmaintained}/boolean-expr/tags.txt (100%) rename {extra => unmaintained}/dns/cache/nx/nx.factor (100%) rename {extra => unmaintained}/dns/cache/rr/rr.factor (100%) rename {extra => unmaintained}/dns/dns.factor (100%) rename {extra => unmaintained}/dns/forwarding/forwarding.factor (100%) rename {extra => unmaintained}/dns/misc/misc.factor (100%) rename {extra => unmaintained}/dns/resolver/resolver.factor (100%) rename {extra => unmaintained}/dns/server/server.factor (100%) rename {extra => unmaintained}/dns/stub/stub.factor (100%) rename {extra => unmaintained}/dns/util/util.factor (100%) rename {extra => unmaintained}/multi-methods/authors.txt (100%) rename {extra => unmaintained}/multi-methods/multi-methods.factor (100%) rename {extra => unmaintained}/multi-methods/summary.txt (100%) rename {extra => unmaintained}/multi-methods/tags.txt (100%) rename {extra => unmaintained}/multi-methods/tests/canonicalize.factor (100%) rename {extra => unmaintained}/multi-methods/tests/definitions.factor (100%) rename {extra => unmaintained}/multi-methods/tests/legacy.factor (100%) rename {extra => unmaintained}/multi-methods/tests/syntax.factor (100%) rename {extra => unmaintained}/multi-methods/tests/topological-sort.factor (100%) rename {extra => unmaintained}/shell/parser/parser.factor (100%) rename {extra => unmaintained}/shell/shell.factor (100%) diff --git a/extra/boolean-expr/authors.txt b/unmaintained/boolean-expr/authors.txt similarity index 100% rename from extra/boolean-expr/authors.txt rename to unmaintained/boolean-expr/authors.txt diff --git a/extra/boolean-expr/boolean-expr.factor b/unmaintained/boolean-expr/boolean-expr.factor similarity index 100% rename from extra/boolean-expr/boolean-expr.factor rename to unmaintained/boolean-expr/boolean-expr.factor diff --git a/extra/boolean-expr/summary.txt b/unmaintained/boolean-expr/summary.txt similarity index 100% rename from extra/boolean-expr/summary.txt rename to unmaintained/boolean-expr/summary.txt diff --git a/extra/boolean-expr/tags.txt b/unmaintained/boolean-expr/tags.txt similarity index 100% rename from extra/boolean-expr/tags.txt rename to unmaintained/boolean-expr/tags.txt diff --git a/extra/dns/cache/nx/nx.factor b/unmaintained/dns/cache/nx/nx.factor similarity index 100% rename from extra/dns/cache/nx/nx.factor rename to unmaintained/dns/cache/nx/nx.factor diff --git a/extra/dns/cache/rr/rr.factor b/unmaintained/dns/cache/rr/rr.factor similarity index 100% rename from extra/dns/cache/rr/rr.factor rename to unmaintained/dns/cache/rr/rr.factor diff --git a/extra/dns/dns.factor b/unmaintained/dns/dns.factor similarity index 100% rename from extra/dns/dns.factor rename to unmaintained/dns/dns.factor diff --git a/extra/dns/forwarding/forwarding.factor b/unmaintained/dns/forwarding/forwarding.factor similarity index 100% rename from extra/dns/forwarding/forwarding.factor rename to unmaintained/dns/forwarding/forwarding.factor diff --git a/extra/dns/misc/misc.factor b/unmaintained/dns/misc/misc.factor similarity index 100% rename from extra/dns/misc/misc.factor rename to unmaintained/dns/misc/misc.factor diff --git a/extra/dns/resolver/resolver.factor b/unmaintained/dns/resolver/resolver.factor similarity index 100% rename from extra/dns/resolver/resolver.factor rename to unmaintained/dns/resolver/resolver.factor diff --git a/extra/dns/server/server.factor b/unmaintained/dns/server/server.factor similarity index 100% rename from extra/dns/server/server.factor rename to unmaintained/dns/server/server.factor diff --git a/extra/dns/stub/stub.factor b/unmaintained/dns/stub/stub.factor similarity index 100% rename from extra/dns/stub/stub.factor rename to unmaintained/dns/stub/stub.factor diff --git a/extra/dns/util/util.factor b/unmaintained/dns/util/util.factor similarity index 100% rename from extra/dns/util/util.factor rename to unmaintained/dns/util/util.factor diff --git a/extra/multi-methods/authors.txt b/unmaintained/multi-methods/authors.txt similarity index 100% rename from extra/multi-methods/authors.txt rename to unmaintained/multi-methods/authors.txt diff --git a/extra/multi-methods/multi-methods.factor b/unmaintained/multi-methods/multi-methods.factor similarity index 100% rename from extra/multi-methods/multi-methods.factor rename to unmaintained/multi-methods/multi-methods.factor diff --git a/extra/multi-methods/summary.txt b/unmaintained/multi-methods/summary.txt similarity index 100% rename from extra/multi-methods/summary.txt rename to unmaintained/multi-methods/summary.txt diff --git a/extra/multi-methods/tags.txt b/unmaintained/multi-methods/tags.txt similarity index 100% rename from extra/multi-methods/tags.txt rename to unmaintained/multi-methods/tags.txt diff --git a/extra/multi-methods/tests/canonicalize.factor b/unmaintained/multi-methods/tests/canonicalize.factor similarity index 100% rename from extra/multi-methods/tests/canonicalize.factor rename to unmaintained/multi-methods/tests/canonicalize.factor diff --git a/extra/multi-methods/tests/definitions.factor b/unmaintained/multi-methods/tests/definitions.factor similarity index 100% rename from extra/multi-methods/tests/definitions.factor rename to unmaintained/multi-methods/tests/definitions.factor diff --git a/extra/multi-methods/tests/legacy.factor b/unmaintained/multi-methods/tests/legacy.factor similarity index 100% rename from extra/multi-methods/tests/legacy.factor rename to unmaintained/multi-methods/tests/legacy.factor diff --git a/extra/multi-methods/tests/syntax.factor b/unmaintained/multi-methods/tests/syntax.factor similarity index 100% rename from extra/multi-methods/tests/syntax.factor rename to unmaintained/multi-methods/tests/syntax.factor diff --git a/extra/multi-methods/tests/topological-sort.factor b/unmaintained/multi-methods/tests/topological-sort.factor similarity index 100% rename from extra/multi-methods/tests/topological-sort.factor rename to unmaintained/multi-methods/tests/topological-sort.factor diff --git a/extra/shell/parser/parser.factor b/unmaintained/shell/parser/parser.factor similarity index 100% rename from extra/shell/parser/parser.factor rename to unmaintained/shell/parser/parser.factor diff --git a/extra/shell/shell.factor b/unmaintained/shell/shell.factor similarity index 100% rename from extra/shell/shell.factor rename to unmaintained/shell/shell.factor From f4f99036ca2173720fc9338dcc7ea30ec45852d5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 07:04:15 -0500 Subject: [PATCH 95/98] Move lint to unmaintained --- {extra => unmaintained}/lint/authors.txt | 0 {extra => unmaintained}/lint/lint-tests.factor | 0 {extra => unmaintained}/lint/lint.factor | 0 {extra => unmaintained}/lint/summary.txt | 0 4 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/lint/authors.txt (100%) rename {extra => unmaintained}/lint/lint-tests.factor (100%) rename {extra => unmaintained}/lint/lint.factor (100%) rename {extra => unmaintained}/lint/summary.txt (100%) diff --git a/extra/lint/authors.txt b/unmaintained/lint/authors.txt similarity index 100% rename from extra/lint/authors.txt rename to unmaintained/lint/authors.txt diff --git a/extra/lint/lint-tests.factor b/unmaintained/lint/lint-tests.factor similarity index 100% rename from extra/lint/lint-tests.factor rename to unmaintained/lint/lint-tests.factor diff --git a/extra/lint/lint.factor b/unmaintained/lint/lint.factor similarity index 100% rename from extra/lint/lint.factor rename to unmaintained/lint/lint.factor diff --git a/extra/lint/summary.txt b/unmaintained/lint/summary.txt similarity index 100% rename from extra/lint/summary.txt rename to unmaintained/lint/summary.txt From 3353a777f76da28cf25f7835225a3bd144613b13 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 07:05:00 -0500 Subject: [PATCH 96/98] Fixing some unit test failures --- .../format/macros/macros-tests.factor | 2 +- basis/combinators/smart/smart-tests.factor | 2 +- .../cpu/ppc/assembler/assembler-tests.factor | 2 -- basis/debugger/debugger-tests.factor | 3 +++ basis/help/markup/markup-tests.factor | 2 +- basis/math/intervals/intervals-tests.factor | 4 +-- basis/peg/ebnf/ebnf-tests.factor | 2 -- basis/peg/peg-tests.factor | 2 -- basis/regexp/parser/parser-tests.factor | 2 +- basis/tools/crossref/crossref-tests.factor | 2 +- basis/tools/crossref/crossref.factor | 25 ++++++++++++++--- basis/tools/profiler/profiler-tests.factor | 2 +- basis/unicode/breaks/breaks-tests.factor | 2 +- .../unicode/collation/collation-tests.factor | 5 ++-- .../unicode/normalize/normalize-tests.factor | 2 -- basis/windows/com/wrapper/wrapper.factor | 2 +- core/continuations/continuations-tests.factor | 12 ++++----- core/kernel/kernel-tests.factor | 27 ++++++++++++------- core/parser/parser-tests.factor | 3 ++- .../client/internals/internals-tests.factor | 2 +- 20 files changed, 62 insertions(+), 43 deletions(-) diff --git a/basis/calendar/format/macros/macros-tests.factor b/basis/calendar/format/macros/macros-tests.factor index 48567539ad..4ba2872b43 100644 --- a/basis/calendar/format/macros/macros-tests.factor +++ b/basis/calendar/format/macros/macros-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test kernel ; +USING: tools.test kernel accessors ; IN: calendar.format.macros [ 2 ] [ { [ 2 ] } attempt-all-quots ] unit-test diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 080379e924..a18ef1f3b8 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test combinators.smart math kernel ; +USING: tools.test combinators.smart math kernel accessors ; IN: combinators.smart.tests : test-bi ( -- 9 11 ) diff --git a/basis/cpu/ppc/assembler/assembler-tests.factor b/basis/cpu/ppc/assembler/assembler-tests.factor index f35a5cfca8..09db4cb050 100644 --- a/basis/cpu/ppc/assembler/assembler-tests.factor +++ b/basis/cpu/ppc/assembler/assembler-tests.factor @@ -114,5 +114,3 @@ make vocabs sequences ; { HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler { HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler { HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler - -"cpu.ppc.assembler" words [ must-infer ] each diff --git a/basis/debugger/debugger-tests.factor b/basis/debugger/debugger-tests.factor index afa4aa1c28..08f84d9335 100644 --- a/basis/debugger/debugger-tests.factor +++ b/basis/debugger/debugger-tests.factor @@ -2,3 +2,6 @@ IN: debugger.tests USING: debugger kernel continuations tools.test ; [ ] [ [ drop ] [ error. ] recover ] unit-test + +[ f ] [ { } vm-error? ] unit-test +[ f ] [ { "A" "B" } vm-error? ] unit-test \ No newline at end of file diff --git a/basis/help/markup/markup-tests.factor b/basis/help/markup/markup-tests.factor index bcd8843b24..93bed37a55 100644 --- a/basis/help/markup/markup-tests.factor +++ b/basis/help/markup/markup-tests.factor @@ -5,7 +5,7 @@ IN: help.markup.tests TUPLE: blahblah quux ; -[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test +[ "int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test [ ] [ \ quux>> print-topic ] unit-test [ ] [ \ >>quux print-topic ] unit-test diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 8b43456901..2b8b3dff24 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -302,8 +302,8 @@ IN: math.intervals.tests : comparison-test ( -- ? ) random-interval random-interval random-comparison - [ [ [ random-element ] bi@ ] dip first execute ] 3keep - second execute dup incomparable eq? [ 2drop t ] [ = ] if ; + [ [ [ random-element ] bi@ ] dip first execute( a b -- ? ) ] 3keep + second execute( a b -- ? ) dup incomparable eq? [ 2drop t ] [ = ] if ; [ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test diff --git a/basis/peg/ebnf/ebnf-tests.factor b/basis/peg/ebnf/ebnf-tests.factor index 58102cffc3..329156d733 100644 --- a/basis/peg/ebnf/ebnf-tests.factor +++ b/basis/peg/ebnf/ebnf-tests.factor @@ -300,8 +300,6 @@ main = Primary "x[i][j].y" primary ] unit-test -'ebnf' compile must-infer - { V{ V{ "a" "b" } "c" } } [ "abc" [EBNF a="a" "b" foo=(a "c") EBNF] ] unit-test diff --git a/basis/peg/peg-tests.factor b/basis/peg/peg-tests.factor index 9a15dd2105..683fa328d8 100644 --- a/basis/peg/peg-tests.factor +++ b/basis/peg/peg-tests.factor @@ -206,5 +206,3 @@ USE: compiler [ ] [ enable-compiler ] unit-test [ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test - -[ [ ] ] [ "" epsilon [ drop [ [ ] ] ] action [ call ] action parse ] unit-test \ No newline at end of file diff --git a/basis/regexp/parser/parser-tests.factor b/basis/regexp/parser/parser-tests.factor index 0e12014eef..5ea9753fba 100644 --- a/basis/regexp/parser/parser-tests.factor +++ b/basis/regexp/parser/parser-tests.factor @@ -4,7 +4,7 @@ IN: regexp.parser.tests : regexp-parses ( string -- ) [ [ ] ] dip '[ _ parse-regexp drop ] unit-test ; -: regexp-fails ( string -- regexp ) +: regexp-fails ( string -- ) '[ _ parse-regexp ] must-fail ; { diff --git a/basis/tools/crossref/crossref-tests.factor b/basis/tools/crossref/crossref-tests.factor index 26c6c4e597..80f5367fb6 100755 --- a/basis/tools/crossref/crossref-tests.factor +++ b/basis/tools/crossref/crossref-tests.factor @@ -1,6 +1,6 @@ USING: math kernel sequences io.files io.pathnames tools.crossref tools.test parser namespaces source-files generic -definitions ; +definitions words accessors compiler.units ; IN: tools.crossref.tests GENERIC: foo ( a b -- c ) diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index feaddc8194..c5cd246f2e 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -13,30 +13,47 @@ GENERIC: uses ( defspec -- seq ) alist ] dip (seq-uses) + ] if ; M: array quot-uses seq-uses ; -M: hashtable quot-uses [ >alist ] dip seq-uses ; +M: hashtable quot-uses assoc-uses ; M: callable quot-uses seq-uses ; M: wrapper quot-uses [ wrapped>> ] dip quot-uses ; M: callable uses ( quot -- assoc ) - H{ } clone [ quot-uses ] keep keys ; + V{ } clone visited [ + H{ } clone [ quot-uses ] keep keys + ] with-variable ; M: word uses def>> uses ; M: link uses { $subsection $link $see-also } article-links ; -M: pathname uses string>> source-file top-level-form>> uses ; +M: pathname uses string>> source-file top-level-form>> [ uses ] [ { } ] if* ; GENERIC: crossref-def ( defspec -- ) diff --git a/basis/tools/profiler/profiler-tests.factor b/basis/tools/profiler/profiler-tests.factor index 0bd3663729..d2e605ecdc 100644 --- a/basis/tools/profiler/profiler-tests.factor +++ b/basis/tools/profiler/profiler-tests.factor @@ -34,7 +34,7 @@ words ; [ 1 ] [ \ foobar counter>> ] unit-test -: fooblah ( -- ) { } [ ] like call ; +: fooblah ( -- ) { } [ ] like call( -- ) ; : foobaz ( -- ) fooblah fooblah ; diff --git a/basis/unicode/breaks/breaks-tests.factor b/basis/unicode/breaks/breaks-tests.factor index 3a26b01213..6d6d4233f5 100644 --- a/basis/unicode/breaks/breaks-tests.factor +++ b/basis/unicode/breaks/breaks-tests.factor @@ -32,7 +32,7 @@ IN: unicode.breaks.tests [ concat [ quot call [ "" like ] map ] curry ] bi unit-test ] each ; -: grapheme-test ( tests quot -- ) +: grapheme-test ( tests -- ) [ [ 1quotation ] [ concat [ >graphemes [ "" like ] map ] curry ] bi unit-test diff --git a/basis/unicode/collation/collation-tests.factor b/basis/unicode/collation/collation-tests.factor index f53a1382ae..fdeb721e65 100644 --- a/basis/unicode/collation/collation-tests.factor +++ b/basis/unicode/collation/collation-tests.factor @@ -11,9 +11,10 @@ IN: unicode.collation.tests : test-two ( str1 str2 -- ) [ +lt+ ] -rot [ string<=> ] 2curry unit-test ; -: test-equality ( str1 str2 -- ) +: test-equality ( str1 str2 -- ? ? ? ? ) { primary= secondary= tertiary= quaternary= } - [ execute ] with with each ; + [ execute( a b -- ? ) ] with with map + first4 ; [ f f f f ] [ "hello" "hi" test-equality ] unit-test [ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test diff --git a/basis/unicode/normalize/normalize-tests.factor b/basis/unicode/normalize/normalize-tests.factor index f774016272..cea880c0b0 100644 --- a/basis/unicode/normalize/normalize-tests.factor +++ b/basis/unicode/normalize/normalize-tests.factor @@ -3,8 +3,6 @@ simple-flat-file io.encodings.utf8 io.files splitting math.parser locals math quotations assocs combinators unicode.normalize.private ; IN: unicode.normalize.tests -{ nfc nfkc nfd nfkd } [ must-infer ] each - [ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test [ "ab\u00064b\u000347\u00034e\u00034d\u000346" ] [ "ab\u000346\u000347\u00064b\u00034e\u00034d" dup reorder ] unit-test diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index a014a56ea0..e78c987cd4 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -132,7 +132,7 @@ unless [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ; : (callbacks>vtbl) ( callbacks -- vtbl ) - [ execute ] void*-array{ } map-as malloc-byte-array ; + [ execute( -- callback ) ] void*-array{ } map-as malloc-byte-array ; : (callbacks>vtbls) ( callbacks -- vtbls ) [ (callbacks>vtbl) ] map ; diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 391b87a44f..f4eeeefb77 100644 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -50,21 +50,19 @@ IN: continuations.tests gc ] unit-test -[ f ] [ { } kernel-error? ] unit-test -[ f ] [ { "A" "B" } kernel-error? ] unit-test - ! ! See how well callstack overflow is handled ! [ clear drop ] must-fail ! ! : callstack-overflow callstack-overflow f ; ! [ callstack-overflow ] must-fail -: don't-compile-me ( n -- ) { } [ ] each ; - -: foo ( -- ) callstack "c" set 3 don't-compile-me ; +: don't-compile-me ( -- ) ; +: foo ( -- ) callstack "c" set don't-compile-me ; : bar ( -- a b ) 1 foo 2 ; -[ 1 3 2 ] [ bar ] unit-test +<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >> + +[ 1 2 ] [ bar ] unit-test [ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 84a356805b..b58c744b05 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -1,7 +1,7 @@ USING: arrays byte-arrays kernel kernel.private math memory namespaces sequences tools.test math.private quotations continuations prettyprint io.streams.string debugger assocs -sequences.private accessors locals.backend grouping ; +sequences.private accessors locals.backend grouping words ; IN: kernel.tests [ 0 ] [ f size ] unit-test @@ -23,20 +23,25 @@ IN: kernel.tests : overflow-d ( -- ) 3 overflow-d ; -[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with - -[ ] [ :c ] unit-test - : (overflow-d-alt) ( -- n ) 3 ; : overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ; +: overflow-r ( -- ) 3 load-local overflow-r ; + +<< +{ overflow-d (overflow-d-alt) overflow-d-alt overflow-r } +[ t "no-compile" set-word-prop ] each +>> + +[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with + +[ ] [ :c ] unit-test + [ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ [ :c ] with-string-writer drop ] unit-test -: overflow-r ( -- ) 3 load-local overflow-r ; - [ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with [ ] [ :c ] unit-test @@ -99,7 +104,9 @@ IN: kernel.tests [ ] [ :c ] unit-test ! Doesn't compile; important -: foo ( a -- b ) 5 + 0 [ ] each ; +: foo ( a -- b ) ; + +<< \ foo t "no-compile" set-word-prop >> [ drop foo ] must-fail [ ] [ :c ] unit-test @@ -109,13 +116,13 @@ IN: kernel.tests [ pick ] dip swap [ pick ] dip swap < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive -: loop ( obj obj -- ) +: loop ( obj -- ) H{ } values swap [ dup length swap ] dip 0 -roll (loop) ; [ loop ] must-fail ! Discovered on Windows -: total-failure-1 ( -- ) "" [ ] map unimplemented ; +: total-failure-1 ( -- a ) "" [ ] map unimplemented ; [ total-failure-1 ] must-fail diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index a8a57ccdaa..e944ecc6f2 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -3,7 +3,8 @@ io.streams.string namespaces classes effects source-files assocs sequences strings io.files io.pathnames definitions continuations sorting classes.tuple compiler.units debugger vocabs vocabs.loader accessors eval combinators lexer -vocabs.parser words.symbol multiline source-files.errors ; +vocabs.parser words.symbol multiline source-files.errors +tools.crossref ; IN: parser.tests [ diff --git a/extra/irc/client/internals/internals-tests.factor b/extra/irc/client/internals/internals-tests.factor index d20ae50bcc..27b5648f97 100644 --- a/extra/irc/client/internals/internals-tests.factor +++ b/extra/irc/client/internals/internals-tests.factor @@ -41,7 +41,7 @@ M: mb-writer dispose drop ; : %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ; : read-matching-message ( chat quot: ( msg -- ? ) -- irc-message ) - [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; + [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; inline : spawning-irc ( quot: ( -- ) -- ) [ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline From 91cd13d2d626428722745cd51933a845a4e8fce3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 07:07:24 -0500 Subject: [PATCH 97/98] mason.test: collect compiler errors at the very end of the process, to catch errors in unit test files --- extra/mason/test/test.factor | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 912fbaa17a..22b932ac5b 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -25,12 +25,6 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; [ file>> ] map prune natural-sort summary-file to-file errors details-file utf8 [ errors. ] with-file-writer ; -: do-compile-errors ( -- ) - compiler-errors get values - compiler-errors-file - compiler-error-messages-file - do-step ; - : do-tests ( -- ) test-all test-failures get test-all-vocabs-file @@ -50,6 +44,12 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; [ benchmark-error-messages-file utf8 [ benchmark-errors. ] with-file-writer ] bi ] bi* ; +: do-compile-errors ( -- ) + compiler-errors get values + compiler-errors-file + compiler-error-messages-file + do-step ; + : benchmark-ms ( quot -- ms ) benchmark 1000 /i ; inline @@ -66,11 +66,12 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; ".." [ bootstrap-time get boot-time-file to-file check-boot-image - [ do-load do-compile-errors ] benchmark-ms load-time-file to-file + [ do-load ] benchmark-ms load-time-file to-file [ generate-help ] benchmark-ms html-help-time-file to-file [ do-tests ] benchmark-ms test-time-file to-file [ do-help-lint ] benchmark-ms help-lint-time-file to-file [ do-benchmarks ] benchmark-ms benchmark-time-file to-file + do-compile-errors ] with-directory ; MAIN: do-all \ No newline at end of file From cd91b2e755cc42649f7837078c4df81eb8368eb6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 10:46:50 -0500 Subject: [PATCH 98/98] tools.errors: fix printing of errors with no associated source file --- basis/tools/errors/errors-tests.factor | 20 ++++++++++++++++++++ basis/tools/errors/errors.factor | 6 ++++-- basis/ui/tools/error-list/error-list.factor | 10 +++++----- 3 files changed, 29 insertions(+), 7 deletions(-) create mode 100644 basis/tools/errors/errors-tests.factor diff --git a/basis/tools/errors/errors-tests.factor b/basis/tools/errors/errors-tests.factor new file mode 100644 index 0000000000..a70aa32be8 --- /dev/null +++ b/basis/tools/errors/errors-tests.factor @@ -0,0 +1,20 @@ +USING: compiler.errors stack-checker.errors tools.test words ; +IN: tools.errors + +DEFER: blah + +[ ] [ + { + T{ compiler-error + { error + T{ inference-error + f + T{ do-not-compile f blah } + +compiler-error+ + blah + } + } + { asset blah } + } + } errors. +] unit-test \ No newline at end of file diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor index 422e08f020..ae55e9a1da 100644 --- a/basis/tools/errors/errors.factor +++ b/basis/tools/errors/errors.factor @@ -14,9 +14,11 @@ M: source-file-error compute-restarts M: source-file-error error-help error>> error-help ; +CONSTANT: +listener-input+ "" + M: source-file-error summary [ - [ file>> [ % ": " % ] [ "" % ] if* ] + [ file>> [ % ": " % ] [ +listener-input+ % ] if* ] [ line#>> [ # ] when* ] bi ] "" make ; @@ -27,7 +29,7 @@ M: source-file-error error. : errors. ( errors -- ) group-by-source-file sort-errors [ - [ nl "==== " write print nl ] + [ nl "==== " write +listener-input+ or print nl ] [ [ nl ] [ error. ] interleave ] bi* ] assoc-each ; diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index 42863a8fd2..5a4fb7376a 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -4,14 +4,14 @@ USING: accessors arrays sequences sorting assocs colors.constants fry combinators combinators.smart combinators.short-circuit editors make memoize compiler.units fonts kernel io.pathnames prettyprint source-files.errors math.parser init math.order models models.arrow -models.arrow.smart models.search models.mapping models.delay debugger namespaces -summary locals ui ui.commands ui.gadgets ui.gadgets.panes +models.arrow.smart models.search models.mapping models.delay debugger +namespaces summary locals ui ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers ui.tools.inspector ui.gadgets.status-bar ui.operations ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs -ui.gadgets.labels ui.baseline-alignment ui.images -compiler.errors calendar ; +ui.gadgets.labels ui.baseline-alignment ui.images ui.tools.listener +compiler.errors calendar tools.errors ; IN: ui.tools.error-list CONSTANT: source-file-icon @@ -39,7 +39,7 @@ SINGLETON: source-file-renderer M: source-file-renderer row-columns drop first2 [ [ source-file-icon ] - [ "" or ] + [ +listener-input+ or ] [ length number>string ] tri* ] output>array ;