Merge branch 'master' into unicode

extra/db/db.factor

@@ -4,12 +4,9 @@ USING: arrays assocs classes continuations kernel math
 namespaces sequences sequences.lib tuples words strings ;
 IN: db
 
-TUPLE: db handle insert-statements update-statements delete-statements select-statements ;
+TUPLE: db handle insert-statements update-statements delete-statements ;
 : <db> ( handle -- obj )
-    H{ } clone
-    H{ } clone
-    H{ } clone
-    H{ } clone
+    H{ } clone H{ } clone H{ } clone
     db construct-boa ;
 
 GENERIC: db-open ( db -- )
@@ -23,11 +20,10 @@ HOOK: db-close db ( handle -- )
         dup db-insert-statements dispose-statements
         dup db-update-statements dispose-statements
         dup db-delete-statements dispose-statements
-        dup db-select-statements dispose-statements
         db-handle db-close
     ] with-variable ;
 
-TUPLE: statement sql params handle bound? ;
+TUPLE: statement sql params handle bound? slot-names ;
 TUPLE: simple-statement ;
 TUPLE: prepared-statement ;
 
@@ -115,5 +111,7 @@ HOOK: rollback-transaction db ( -- )
     dup string? [
         <simple-statement> [ execute-statement ] with-disposal
     ] [
-        [ [ sql-command ] each ] with-transaction
+        ! [
+            [ sql-command ] each
+        ! ] with-transaction
     ] if ;

extra/db/postgresql/postgresql.factor

@@ -3,7 +3,8 @@
 USING: arrays assocs alien alien.syntax continuations io
 kernel math math.parser namespaces prettyprint quotations
 sequences debugger db db.postgresql.lib db.postgresql.ffi
-db.tuples db.types tools.annotations math.ranges ;
+db.tuples db.types tools.annotations math.ranges
+combinators ;
 IN: db.postgresql
 
 TUPLE: postgresql-db host port pgopts pgtty db user pass ;
@@ -52,11 +53,19 @@ M: postgresql-result-set #columns ( result-set -- n )
 M: postgresql-result-set row-column ( result-set n -- obj )
     >r dup result-set-handle swap result-set-n r> PQgetvalue ;
 
-M: postgresql-result-set row-column ( result-set n -- obj )
-    >r dup result-set-handle swap result-set-n r> PQgetvalue ;
+M: postgresql-result-set row-column-typed ( result-set n type -- obj )
+    >r row-column r> sql-type>factor-type ;
+
+M: postgresql-result-set sql-type>factor-type ( obj type -- newobj )
+    {
+        { INTEGER [ string>number ] }
+        { BIG_INTEGER [ string>number ] }
+        { DOUBLE [ string>number ] }
+        [ drop ]
+    } case ;
 
 M: postgresql-statement insert-statement ( statement -- id )
-    query-results [ break 0 row-column ] with-disposal ;
+    query-results [ 0 row-column ] with-disposal string>number ;
 
 M: postgresql-statement query-results ( query -- result-set )
     dup statement-params [
@@ -202,7 +211,7 @@ M: postgresql-db drop-sql ( columns table -- seq )
         over native-id? [ drop-function , ] [ 2drop ] if
     ] { } make ;
 
-M: postgresql-db insert-sql* ( columns table -- sql )
+M: postgresql-db insert-sql* ( columns table -- slot-names sql )
     [
         "select add_" % %
         "(" %
@@ -210,7 +219,7 @@ M: postgresql-db insert-sql* ( columns table -- sql )
         ")" %
     ] "" make ;
 
-M: postgresql-db update-sql* ( columns table -- sql )
+M: postgresql-db update-sql* ( columns table -- slot-names sql )
     [
         "update " %
         %
@@ -222,7 +231,7 @@ M: postgresql-db update-sql* ( columns table -- sql )
         [ primary-key? ] find nip second dup % " = $" % length 2 + #
     ] "" make ;
 
-M: postgresql-db delete-sql* ( columns table -- sql )
+M: postgresql-db delete-sql* ( columns table -- slot-names sql )
     [
         "delete from " %
         %
@@ -230,7 +239,7 @@ M: postgresql-db delete-sql* ( columns table -- sql )
         first second % " = $1" %
     ] "" make ;
 
-M: postgresql-db select-sql* ( columns table -- sql )
+M: postgresql-db select-sql ( columns table -- slot-names sql )
     drop ;
 
 M: postgresql-db tuple>params ( columns tuple -- obj )

extra/db/sqlite/ffi/ffi.factor

@@ -125,6 +125,8 @@ 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 ) ;
+FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: int 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 ) ;

extra/db/sqlite/lib/lib.factor

@@ -96,6 +96,14 @@ IN: db.sqlite.lib
 : sqlite-column ( handle index -- string )
     sqlite3_column_text ;
 
+: sqlite-column-typed ( handle index type -- obj )
+    {
+        { INTEGER [ sqlite3_column_int ] }
+        { BIG_INTEGER [ sqlite3_column_int64 ] }
+        { TEXT [ sqlite3_column_text ] }
+        { DOUBLE [ sqlite3_column_double ] }
+    } case ;
+
 ! TODO
 : sqlite-row ( handle -- seq )
     dup sqlite-#columns [ sqlite-column ] with map ;

extra/db/sqlite/sqlite.factor

@@ -63,6 +63,9 @@ M: sqlite-result-set #columns ( result-set -- n )
 M: sqlite-result-set row-column ( result-set n -- obj )
     >r result-set-handle r> sqlite-column ;
 
+M: sqlite-result-set row-column-typed ( result-set n type -- obj )
+    >r result-set-handle r> sqlite-column-typed ;
+
 M: sqlite-result-set advance-row ( result-set -- )
     [ result-set-handle sqlite-next ] keep
     set-sqlite-result-set-has-more? ;
@@ -111,6 +114,10 @@ M: sqlite-db insert-sql* ( columns table -- sql )
         ")" %
     ] "" make ;
 
+: where-primary-key% ( columns -- )
+    " where " %
+    [ primary-key? ] find nip second dup % " = :" % % ;
+
 M: sqlite-db update-sql* ( columns table -- sql )
     [
         "update " %
@@ -118,8 +125,7 @@ M: sqlite-db update-sql* ( columns table -- sql )
         " set " %
         dup remove-id
         [ ", " % ] [ second dup % " = :" % % ] interleave
-        " where " %
-        [ primary-key? ] find nip second dup % " = :" % %
+        where-primary-key%
     ] "" make ;
 
 M: sqlite-db delete-sql* ( columns table -- sql )
@@ -130,13 +136,18 @@ M: sqlite-db delete-sql* ( columns table -- sql )
         first second dup % " = :" % %
     ] "" make ;
 
-M: sqlite-db select-sql* ( columns table -- sql )
+: select-interval ( interval name -- )
+    ;
+
+: select-sequence ( seq name -- )
+    ;
+
+M: sqlite-db select-sql ( columns table -- sql )
     [
         "select ROWID, " %
-        swap [ ", " % ] [ second % ] interleave
-        " from " %
-        %
-        " where ROWID = :ID" %
+        over [ ", " % ] [ second % ] interleave
+        " from " % %
+        " where " %
     ] "" make ;
 
 M: sqlite-db tuple>params ( columns tuple -- obj )

extra/db/tuples/tuples-tests.factor

@@ -31,7 +31,7 @@ SYMBOL: the-person
     [ ] [ the-person get update-tuple ] unit-test
 
     [ ] [ the-person get delete-tuple ] unit-test
-    [ ] [ person drop-table ] unit-test ;
+    ; ! 1 [ ] [ person drop-table ] unit-test ;
 
 : test-sqlite ( -- )
     "tuples-test.db" resource-path <sqlite-db> [
@@ -54,17 +54,17 @@ person "PERSON"
 "billy" 10 3.14 <person> the-person set
 
 ! test-sqlite
-test-postgresql
+ test-postgresql
 
-person "PERSON"
-{
-    { "the-id" "ID" INTEGER +assigned-id+ }
-    { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
-    { "the-number" "AGE" INTEGER { +default+ 0 } }
-    { "real" "REAL" DOUBLE { +default+ 0.3 } }
-} define-persistent
+! person "PERSON"
+! {
+    ! { "the-id" "ID" INTEGER +assigned-id+ }
+    ! { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
+    ! { "the-number" "AGE" INTEGER { +default+ 0 } }
+    ! { "real" "REAL" DOUBLE { +default+ 0.3 } }
+! } define-persistent
 
-1 "billy" 20 6.28 <assigned-person> the-person set
+! 1 "billy" 20 6.28 <assigned-person> the-person set
 
 ! test-sqlite
 ! test-postgresql

extra/db/tuples/tuples.factor

@@ -41,10 +41,25 @@ TUPLE: no-slot-named ;
 HOOK: create-sql db ( columns table -- seq )
 HOOK: drop-sql db ( columns table -- seq )
 
-HOOK: insert-sql* db ( columns table -- sql )
-HOOK: update-sql* db ( columns table -- sql )
-HOOK: delete-sql* db ( columns table -- sql )
-HOOK: select-sql* db ( columns table -- sql )
+HOOK: insert-sql* db ( columns table -- slot-names sql )
+HOOK: update-sql* db ( columns table -- slot-names sql )
+HOOK: delete-sql* db ( columns table -- slot-names sql )
+HOOK: select-sql db ( tuple -- statement )
+
+HOOK: row-column-typed db ( result-set n type -- sql )
+HOOK: sql-type>factor-type db ( obj type -- obj )
+HOOK: tuple>params db ( columns tuple -- obj )
+
+
+HOOK: make-slot-names* db ( quot -- seq )
+HOOK: column-slot-name% db ( spec -- )
+HOOK: column-bind-name% db ( spec -- )
+
+: make-slots-names ( quot -- seq str )
+    [ make-slot-names* ] "" make ; inline
+: slot-name% ( seq -- ) first % ;
+: column-name% ( seq -- ) second % ;
+: column-type% ( seq -- ) third % ;
 
 : insert-sql ( columns class -- statement )
     db get db-insert-statements [ insert-sql* ] cache-statement ;
@@ -55,10 +70,6 @@ HOOK: select-sql* db ( columns table -- sql )
 : delete-sql ( columns class -- statement )
     db get db-delete-statements [ delete-sql* ] cache-statement ;
 
-: select-sql ( columns class -- statement )
-    db get db-select-statements [ select-sql* ] cache-statement ;
-
-HOOK: tuple>params db ( columns tuple -- obj )
 
 : tuple-statement ( columns tuple quot -- statement )
     >r [ tuple>params ] 2keep class r> call
@@ -90,8 +101,8 @@ HOOK: tuple>params db ( columns tuple -- obj )
 : delete-tuple ( tuple -- )
     [ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ;
 
-! : select-tuple ( tuple -- )
-  !  [ select-sql ] bind-tuple do-query ;
+: select-tuple ( tuple -- )
+    [ select-sql ] keep do-query ;
 
 : persist ( tuple -- )
     dup primary-key [ update-tuple ] [ insert-tuple ] if ;

extra/inverse/inverse.factor

@@ -100,7 +100,7 @@ M: math-inverse inverse
     [ drop swap-inverse ] [ pull-inverse ] if ;
 
 M: pop-inverse inverse
-    [ "pop-length" word-prop cut-slice swap ] keep
+    [ "pop-length" word-prop cut-slice swap >quotation ] keep
     "pop-inverse" word-prop compose call ;
 
 : (undo) ( revquot -- )

extra/io/unix/select/select.factor

@@ -17,14 +17,18 @@ TUPLE: select-mx read-fdset write-fdset ;
     FD_SETSIZE 8 * <bit-array> over set-select-mx-read-fdset
     FD_SETSIZE 8 * <bit-array> over set-select-mx-write-fdset ;
 
+: clear-nth ( n seq -- ? )
+    [ nth ] 2keep f -rot set-nth ;
+
 : handle-fd ( fd task fdset mx -- )
-    roll munge rot nth [ swap handle-io-task ] [ 2drop ] if ;
+    roll munge rot clear-nth
+    [ swap handle-io-task ] [ 2drop ] if ;
 
 : handle-fdset ( tasks fdset mx -- )
     [ handle-fd ] 2curry assoc-each ;
 
 : init-fdset ( tasks fdset -- )
-    dup clear-bits
+    ! dup clear-bits
     [ >r drop t swap munge r> set-nth ] curry assoc-each ;
 
 : read-fdset/tasks
@@ -33,13 +37,19 @@ TUPLE: select-mx read-fdset write-fdset ;
 : write-fdset/tasks
     { mx-writes select-mx-write-fdset } get-slots ;
 
-: init-fdsets ( mx -- read write except )
+: max-fd dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
+
+: num-fds ( mx -- n )
+    dup mx-reads max-fd swap mx-writes max-fd max 1+ ;
+
+: init-fdsets ( mx -- nfds read write except )
+    [ num-fds ] keep
     [ read-fdset/tasks tuck init-fdset ] keep
     write-fdset/tasks tuck init-fdset
     f ;
 
 M: select-mx wait-for-events ( ms mx -- )
-    swap >r FD_SETSIZE over init-fdsets r> make-timeval
+    swap >r dup init-fdsets r> make-timeval
     select multiplexer-error
     dup read-fdset/tasks pick handle-fdset
     dup write-fdset/tasks rot handle-fdset ;

extra/tools/profiler/profiler.factor

@@ -59,5 +59,7 @@ M: string (profile.)
 : vocabs-profile. ( -- )
     "Call counts for all vocabularies:" print
     vocabs [
-        dup words [ profile-counter ] map sum
+        dup words
+        [ "predicating" word-prop not ] subset
+        [ profile-counter ] map sum
     ] { } map>assoc counters. ;

extra/xml/tests/soap.factor

@@ -9,6 +9,6 @@ USING: sequences xml kernel arrays xml.utilities io.files tools.test ;
     [ assemble-data ] map ;
 
 [ "http://www.foxnews.com/oreilly/" ] [
-    "extra/xml/test/soap.xml" resource-path file>xml
+    "extra/xml/tests/soap.xml" resource-path file>xml
     parse-result first first
 ] unit-test

extra/xml/tests/test.factor

@@ -7,7 +7,7 @@ USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
 
 ! This is insufficient
 SYMBOL: xml-file
-[ ] [ "extra/xml/test/test.xml" resource-path
+[ ] [ "extra/xml/tests/test.xml" resource-path
     [ file>xml ] with-html-entities xml-file set ] unit-test
 [ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test
 [ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test