Merge git://factorcode.org/git/factor

core/compiler/units/units.factor

@@ -42,7 +42,7 @@ definition-observers global [ V{ } like ] change-at
 GENERIC: definitions-changed ( assoc obj -- )
 
 : add-definition-observer ( obj -- )
-    definition-observers get push ;
+    definition-observers get push-new ;
 
 : remove-definition-observer ( obj -- )
     definition-observers get delete ;

core/threads/threads-docs.factor

@@ -19,8 +19,7 @@ ARTICLE: "threads-yield" "Yielding and suspending threads"
 { $subsection yield }
 "Sleeping for a period of time:"
 { $subsection sleep }
-"Interruptible sleep:"
+"Interrupting sleep:"
-{ $subsection nap }
 { $subsection interrupt }
 "Threads can be suspended and woken up at some point in the future when a condition is satisfied:"
 { $subsection suspend }
@@ -106,14 +105,17 @@ HELP: stop
 HELP: yield
 { $description "Adds the current thread to the end of the run queue, and switches to the next runnable thread." } ;
 
+HELP: sleep-until
+{ $values { "time/f" "a non-negative integer or " { $link f } } }
+{ $description "Suspends the current thread until the given time, or indefinitely if a value of " { $link f } " is passed in."
+$nl
+"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;
+
 HELP: sleep
 { $values { "ms" "a non-negative integer" } }
-{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds." }
+{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds."
-{ $errors "Throws an error if another thread interrupted the sleep with " { $link interrupt } "." } ;
+$nl
-
+"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;
-HELP: nap
-{ $values { "ms/f" "a non-negative integer or " { $link f } } { "?" "a boolean indicating whether the thread was interrupted" } }
-{ $description "Suspends the current thread until another thread interrupts it with " { $link interrupt } ". If the input parameter is not " { $link f } ", then the thread will also wake up if the timeout expires before an interrupt is received." } ;
 
 HELP: interrupt
 { $values { "thread" thread } }

core/threads/threads.factor

@@ -75,12 +75,15 @@ PRIVATE>
 : sleep-queue 43 getenv ;
 
 : resume ( thread -- )
+    f over set-thread-state
     check-registered run-queue push-front ;
 
 : resume-now ( thread -- )
+    f over set-thread-state
     check-registered run-queue push-back ;
 
 : resume-with ( obj thread -- )
+    f over set-thread-state
     check-registered 2array run-queue push-front ;
 
 <PRIVATE
@@ -131,34 +134,27 @@ PRIVATE>
         self swap call next
     ] callcc1 2nip ; inline
 
-: yield ( -- ) [ resume ] "yield" suspend drop ;
+: yield ( -- ) [ resume ] f suspend drop ;
 
-GENERIC: nap-until ( time -- ? )
+GENERIC: sleep-until ( time/f -- )
 
-M: integer nap-until [ schedule-sleep ] curry "sleep" suspend ;
+M: integer sleep-until
+    [ schedule-sleep ] curry "sleep" suspend drop ;
 
-M: f nap-until drop [ drop ] "interrupt" suspend ;
+M: f sleep-until
+    drop [ drop ] "interrupt" suspend drop ;
 
-GENERIC: nap ( time -- ? )
+GENERIC: sleep ( ms -- )
 
-M: real nap millis + >integer nap-until ;
+M: real sleep
-
+    millis + >integer sleep-until ;
-M: f nap nap-until ;
-
-: sleep-until ( time -- )
-    nap-until [ "Sleep interrupted" throw ] when ;
-
-: sleep ( time -- )
-    nap [ "Sleep interrupted" throw ] when ;
 
 : interrupt ( thread -- )
-    dup self eq? [
+    dup thread-state [
-        drop
-    ] [
         dup thread-sleep-entry [ sleep-queue heap-delete ] when*
         f over set-thread-sleep-entry
-        t swap resume-with
+        dup resume
-    ] if ;
+    ] when drop ;
 
 : (spawn) ( thread -- )
     [
@@ -204,6 +200,7 @@ M: f nap nap-until ;
     initial-thread global
     [ drop f "Initial" [ die ] <thread> ] cache
     <box> over set-thread-continuation
+    f over set-thread-state
     dup register-thread
     set-self ;
 

extra/alarms/alarms.factor

@@ -62,7 +62,7 @@ SYMBOL: alarm-thread
 
 : alarm-thread-loop ( -- )
     alarms get-global
-    dup next-alarm nap-until drop
+    dup next-alarm sleep-until
     dup trigger-alarms
     alarm-thread-loop ;
 

extra/calendar/calendar.factor

@@ -473,9 +473,9 @@ M: timestamp year. ( timestamp -- )
 : seconds-since-midnight ( timestamp -- x )
     dup beginning-of-day timestamp- ;
 
-M: timestamp nap-until timestamp>millis nap-until ;
+M: timestamp sleep-until timestamp>millis sleep-until ;
 
-M: dt nap from-now nap-until ;
+M: dt sleep from-now sleep-until ;
 
 {
     { [ unix? ] [ "calendar.unix" ] }

extra/db/db.factor

@@ -1,14 +1,18 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs classes continuations kernel math
-namespaces sequences sequences.lib tuples words strings ;
+namespaces sequences sequences.lib tuples words strings
+tools.walker ;
 IN: db
 
-TUPLE: db handle insert-statements update-statements delete-statements ;
+TUPLE: db handle ;
+! TUPLE: db handle insert-statements update-statements delete-statements ;
 : <db> ( handle -- obj )
-    H{ } clone H{ } clone H{ } clone
+    ! H{ } clone H{ } clone H{ } clone
     db construct-boa ;
 
+GENERIC: make-db* ( seq class -- db )
+: make-db ( seq class -- db ) construct-empty make-db* ;
 GENERIC: db-open ( db -- )
 HOOK: db-close db ( handle -- )
 
@@ -17,22 +21,29 @@ HOOK: db-close db ( handle -- )
 
 : dispose-db ( db -- ) 
     dup db [
-        dup db-insert-statements dispose-statements
+        ! dup db-insert-statements dispose-statements
-        dup db-update-statements dispose-statements
+        ! dup db-update-statements dispose-statements
-        dup db-delete-statements dispose-statements
+        ! dup db-delete-statements dispose-statements
         db-handle db-close
     ] with-variable ;
 
-TUPLE: statement sql params handle bound? slot-names ;
+TUPLE: statement handle sql in-params out-params bind-params bound? ;
+: <statement> ( sql in out -- statement )
+    {
+        set-statement-sql
+        set-statement-in-params
+        set-statement-out-params
+    } statement construct ;
+
 TUPLE: simple-statement ;
 TUPLE: prepared-statement ;
 
-HOOK: <simple-statement> db ( str -- statement )
+HOOK: <simple-statement> db ( str in out -- statement )
-HOOK: <prepared-statement> db ( str -- statement )
+HOOK: <prepared-statement> db ( str in out -- statement )
 GENERIC: prepare-statement ( statement -- )
 GENERIC: bind-statement* ( obj statement -- )
 GENERIC: reset-statement ( statement -- )
-GENERIC: insert-statement ( statement -- id )
+GENERIC: bind-tuple ( tuple statement -- )
 
 TUPLE: result-set sql params handle n max ;
 GENERIC: query-results ( query -- result-set )
@@ -42,12 +53,17 @@ GENERIC# row-column 1 ( result-set n -- obj )
 GENERIC: advance-row ( result-set -- )
 GENERIC: more-rows? ( result-set -- ? )
 
-: execute-statement ( statement -- ) query-results dispose ;
+: execute-statement ( statement -- )
+    dup sequence? [
+        [ execute-statement ] each
+    ] [
+        query-results dispose
+    ] if ;
 
 : bind-statement ( obj statement -- )
     dup statement-bound? [ dup reset-statement ] when
     [ bind-statement* ] 2keep
-    [ set-statement-params ] keep
+    [ set-statement-bind-params ] keep
     t swap set-statement-bound? ;
 
 : init-result-set ( result-set -- )
@@ -55,7 +71,7 @@ GENERIC: more-rows? ( result-set -- ? )
     0 swap set-result-set-n ;
 
 : <result-set> ( query handle tuple -- result-set )
-    >r >r { statement-sql statement-params } get-slots r>
+    >r >r { statement-sql statement-in-params } get-slots r>
     {
         set-result-set-sql
         set-result-set-params
@@ -75,17 +91,15 @@ GENERIC: more-rows? ( result-set -- ? )
 : query-map ( statement quot -- seq )
     accumulator >r query-each r> { } like ; inline
 
-: with-db ( db quot -- )
+: with-db ( db seq quot -- )
-    [
+    >r make-db dup db-open db r>
-        over db-open
+    [ db get swap [ drop ] swap compose with-disposal ] curry with-variable ;
-        [ db swap with-variable ] curry with-disposal
-    ] with-scope ;
 
-: do-query ( query -- result-set )
+: default-query ( query -- result-set )
     query-results [ [ sql-row ] query-map ] with-disposal ;
 
 : do-bound-query ( obj query -- rows )
-    [ bind-statement ] keep do-query ;
+    [ bind-statement ] keep default-query ;
 
 : do-bound-command ( obj query -- )
     [ bind-statement ] keep execute-statement ;
@@ -105,11 +119,11 @@ HOOK: rollback-transaction db ( -- )
     ] with-variable ;
 
 : sql-query ( sql -- rows )
-    <simple-statement> [ do-query ] with-disposal ;
+    f f <simple-statement> [ default-query ] with-disposal ;
 
 : sql-command ( sql -- )
     dup string? [
-        <simple-statement> [ execute-statement ] with-disposal
+        f f <simple-statement> [ execute-statement ] with-disposal
     ] [
         ! [
             [ sql-command ] each

extra/db/postgresql/lib/lib.factor

@@ -2,21 +2,25 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays continuations db io kernel math namespaces
 quotations sequences db.postgresql.ffi alien alien.c-types
-db.types ;
+db.types tools.walker ascii splitting ;
 IN: db.postgresql.lib
 
 : postgresql-result-error-message ( res -- str/f )
     dup zero? [
         drop f
     ] [
-        PQresultErrorMessage [ CHAR: \n = ] right-trim
+        PQresultErrorMessage [ blank? ] trim
     ] if ;
 
 : postgres-result-error ( res -- )
     postgresql-result-error-message [ throw ] when* ;
 
+: (postgresql-error-message) ( handle -- str )
+    PQerrorMessage
+    "\n" split [ [ blank? ] trim ] map "\n" join ;
+
 : postgresql-error-message ( -- str )
-    db get db-handle PQerrorMessage [ CHAR: \n = ] right-trim ;
+    db get db-handle (postgresql-error-message) ;
 
 : postgresql-error ( res -- res )
     dup [ postgresql-error-message throw ] unless ;
@@ -27,7 +31,7 @@ IN: db.postgresql.lib
 
 : connect-postgres ( host port pgopts pgtty db user pass -- conn )
     PQsetdbLogin
-    dup PQstatus zero? [ postgresql-error-message throw ] unless ;
+    dup PQstatus zero? [ (postgresql-error-message) throw ] unless ;
 
 : do-postgresql-statement ( statement -- res )
     db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [
@@ -37,9 +41,9 @@ IN: db.postgresql.lib
 : do-postgresql-bound-statement ( statement -- res )
     >r db get db-handle r>
     [ statement-sql ] keep
-    [ statement-params length f ] keep
+    [ statement-bind-params length f ] keep
-    statement-params
+    statement-bind-params
-    [ first number>string* malloc-char-string ] map >c-void*-array
+    [ number>string* malloc-char-string ] map >c-void*-array
     f f 0 PQexecParams
     dup postgresql-result-ok? [
         dup postgresql-result-error-message swap PQclear throw

extra/db/postgresql/postgresql-tests.factor

@@ -1,13 +1,14 @@
 ! You will need to run  'createdb factor-test' to create the database.
 ! Set username and password in  the 'connect' word.
 
-USING: kernel db.postgresql alien continuations io prettyprint
+USING: kernel db.postgresql alien continuations io classes
-sequences namespaces tools.test db db.types ;
+prettyprint sequences namespaces tools.test db
+db.tuples db.types unicode.case ;
 IN: temporary
 
 IN: scratchpad
 : test-db ( -- postgresql-db )
-    "localhost" "postgres" "" "factor-test" <postgresql-db> ;
+    { "localhost" "postgres" "" "factor-test" } postgresql-db ;
 IN: temporary
 
 [ ] [ test-db [ ] with-db ] unit-test
@@ -39,7 +40,7 @@ IN: temporary
 ] [
     test-db [
         "select * from person where name = $1 and country = $2"
-        <simple-statement> [
+        f f <simple-statement> [
             { { "Jane" TEXT } { "New Zealand" TEXT } }
             over do-bound-query
 
@@ -108,3 +109,248 @@ IN: temporary
         "select * from person" sql-query length
     ] with-db
 ] unit-test
+
+
+: with-dummy-db ( quot -- )
+    >r T{ postgresql-db } db r> with-variable ;
+
+! TEST TUPLE DB
+
+TUPLE: puppy id name age ;
+: <puppy> ( name age -- puppy )
+    { set-puppy-name set-puppy-age } puppy construct ;
+
+puppy "PUPPY" {
+    { "id" "ID" +native-id+ +not-null+ }
+    { "name" "NAME" { VARCHAR 256 } }
+    { "age" "AGE" INTEGER }
+} define-persistent
+
+TUPLE: kitty id name age ;
+: <kitty> ( name age -- kitty )
+    { set-kitty-name set-kitty-age } kitty construct ;
+
+kitty "KITTY" {
+    { "id" "ID" INTEGER +assigned-id+ }
+    { "name" "NAME" TEXT }
+    { "age" "AGE" INTEGER }
+} define-persistent
+
+TUPLE: basket id puppies kitties ;
+basket "BASKET"
+{
+    { "id" "ID" +native-id+ +not-null+ }
+    { "location" "LOCATION" TEXT }
+    { "puppies" { +has-many+ puppy } }
+    { "kitties" { +has-many+ kitty } }
+} define-persistent
+
+! Create table
+[
+    "create table puppy(id serial primary key not null, name varchar 256, age integer);"
+] [
+    T{ postgresql-db } db [
+        puppy dup db-columns swap db-table create-table-sql >lower
+    ] with-variable
+] unit-test
+
+[
+    "create table kitty(id integer primary key, name text, age integer);"
+] [
+    T{ postgresql-db } db [
+        kitty dup db-columns swap db-table create-table-sql >lower
+    ] with-variable
+] unit-test
+
+[
+    "create table basket(id serial primary key not null, location text);"
+] [
+    T{ postgresql-db } db [
+        basket dup db-columns swap db-table create-table-sql >lower
+    ] with-variable
+] unit-test
+
+! Create function
+[
+    "create function add_puppy(varchar,integer) returns bigint as 'insert into puppy(name, age) values($1, $2); select currval(''puppy_id_seq'');' language sql;"
+] [
+    T{ postgresql-db } db [
+        puppy dup db-columns swap db-table create-function-sql >lower
+    ] with-variable
+] unit-test
+
+! Drop table
+
+[
+    "drop table puppy;"
+] [
+    T{ postgresql-db } db [
+        puppy db-table drop-table-sql >lower
+    ] with-variable
+] unit-test
+
+[
+    "drop table kitty;"
+] [
+    T{ postgresql-db } db [
+        kitty db-table drop-table-sql >lower
+    ] with-variable
+] unit-test
+
+[
+    "drop table basket;"
+] [
+    T{ postgresql-db } db [
+        basket db-table drop-table-sql >lower
+    ] with-variable
+] unit-test
+
+
+! Drop function
+[
+    "drop function add_puppy(varchar, integer);"
+] [
+    T{ postgresql-db } db [
+        puppy dup db-columns swap db-table drop-function-sql >lower
+    ] with-variable
+] unit-test
+
+! Insert
+[
+] [
+    T{ postgresql-db } db [
+        puppy <insert-native-statement>
+    ] with-variable
+] unit-test
+
+[
+    "insert into kitty(id, name, age) values($1, $2, $3);"
+    {
+        T{
+            sql-spec
+            f
+            "id"
+            "ID"
+            INTEGER
+            { +assigned-id+ }
+            +assigned-id+
+        }
+        T{ sql-spec f "name" "NAME" TEXT { } f }
+        T{ sql-spec f "age" "AGE" INTEGER { } f }
+    }
+    { }
+] [
+    T{ postgresql-db } db [
+        kitty <insert-assigned-statement>
+    ] with-variable
+] unit-test
+
+! Update
+[
+    "update puppy set name = $1, age = $2 where id = $3"
+    {
+        T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
+        T{ sql-spec f "age" "AGE" INTEGER { } f }
+        T{
+            sql-spec
+            f
+            "id"
+            "ID"
+            +native-id+
+            { +not-null+ }
+            +native-id+
+        }
+    }
+    { }
+] [
+    T{ postgresql-db } db [
+        puppy dup db-columns swap db-table <update-tuple-statement> >r >r >lower r> r>
+    ] with-variable
+] unit-test
+
+[
+    "update kitty set name = $1, age = $2 where id = $3"
+    {
+        T{ sql-spec f "name" "NAME" TEXT { } f }
+        T{ sql-spec f "age" "AGE" INTEGER { } f }
+        T{
+            sql-spec
+            f
+            "id"
+            "ID"
+            INTEGER
+            { +assigned-id+ }
+            +assigned-id+
+        }
+    }
+    { }
+] [
+    T{ postgresql-db } db [
+        kitty dup db-columns swap db-table <update-tuple-statement> >r >r >lower r> r>
+    ] with-variable
+] unit-test
+
+! Delete
+[
+    "delete from puppy where id = $1"
+    {
+        T{
+            sql-spec
+            f
+            "id"
+            "ID"
+            +native-id+
+            { +not-null+ }
+            +native-id+
+        }
+    }
+    { }
+] [
+    T{ postgresql-db } db [
+        puppy dup db-columns swap db-table <delete-tuple-statement> >r >r >lower r> r>
+    ] with-variable
+] unit-test
+
+[
+    "delete from KITTY where ID = $1"
+    {
+        T{
+            sql-spec
+            f
+            "id"
+            "ID"
+            INTEGER
+            { +assigned-id+ }
+            +assigned-id+
+        }
+    }
+    { }
+] [
+    T{ postgresql-db } db [
+        kitty dup db-columns swap db-table <delete-tuple-statement>
+    ] with-variable
+] unit-test
+
+! Select
+[
+    "select from PUPPY ID, NAME, AGE where NAME = $1;"
+    { T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } }
+    {
+        T{
+            sql-spec
+            f
+            "id"
+            "ID"
+            +native-id+
+            { +not-null+ }
+            +native-id+
+        }
+        T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
+        T{ sql-spec f "age" "AGE" INTEGER { } f }
+    }
+] [
+    T{ postgresql-db } db [
+        T{ puppy f f "Mr. Clunkers" }
+        <select-by-slots-statement>
+    ] with-variable
+] unit-test

extra/db/postgresql/postgresql.factor

@@ -4,25 +4,28 @@ 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
-combinators ;
+combinators sequences.lib classes locals words tools.walker ;
 IN: db.postgresql
 
 TUPLE: postgresql-db host port pgopts pgtty db user pass ;
 TUPLE: postgresql-statement ;
 TUPLE: postgresql-result-set ;
-: <postgresql-statement> ( statement -- postgresql-statement )
+: <postgresql-statement> ( statement in out -- postgresql-statement )
+    <statement>
     postgresql-statement construct-delegate ;
 
-: <postgresql-db> ( host user pass db -- obj )
+M: postgresql-db make-db* ( seq tuple -- db )
-    {
+    >r first4 r> [
-        set-postgresql-db-host
+        {
-        set-postgresql-db-user
+            set-postgresql-db-host
-        set-postgresql-db-pass
+            set-postgresql-db-user
-        set-postgresql-db-db
+            set-postgresql-db-pass
-    } postgresql-db construct ;
+            set-postgresql-db-db
+        } set-slots
+    ] keep ;
 
 M: postgresql-db db-open ( db -- )
-    dup {
+        dup {
         postgresql-db-host
         postgresql-db-port
         postgresql-db-pgopts
@@ -35,15 +38,18 @@ M: postgresql-db db-open ( db -- )
 M: postgresql-db dispose ( db -- )
     db-handle PQfinish ;
 
-: with-postgresql ( host ust pass db quot -- )
-    >r <postgresql-db> r> with-disposal ;
-
 M: postgresql-statement bind-statement* ( seq statement -- )
-    set-statement-params ;
+    set-statement-bind-params ;
 
 M: postgresql-statement reset-statement ( statement -- )
     drop ;
 
+M: postgresql-statement bind-tuple ( tuple statement -- )
+    [
+        statement-in-params
+        [ sql-spec-slot-name swap get-slot-named ] with map
+    ] keep set-statement-bind-params ;
+
 M: postgresql-result-set #rows ( result-set -- n )
     result-set-handle PQntuples ;
 
@@ -56,19 +62,8 @@ M: postgresql-result-set row-column ( result-set n -- obj )
 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 [ 0 row-column ] with-disposal string>number ;
-
 M: postgresql-statement query-results ( query -- result-set )
-    dup statement-params [
+    dup statement-bind-params [
         over [ bind-statement ] keep
         do-postgresql-bound-statement
     ] [
@@ -96,17 +91,15 @@ M: postgresql-result-set dispose ( result-set -- )
 M: postgresql-statement prepare-statement ( statement -- )
     [
         >r db get db-handle "" r>
-        dup statement-sql swap statement-params
+        dup statement-sql swap statement-in-params
         length f PQprepare postgresql-error
     ] keep set-statement-handle ;
 
-M: postgresql-db <simple-statement> ( sql -- statement )
+M: postgresql-db <simple-statement> ( sql in out -- statement )
-    { set-statement-sql } statement construct
     <postgresql-statement> ;
 
-M: postgresql-db <prepared-statement> ( sql -- statement )
+M: postgresql-db <prepared-statement> ( sql in out -- statement )
-    { set-statement-sql } statement construct
+    <postgresql-statement> dup prepare-statement ;
-    <postgresql-statement> ;
 
 M: postgresql-db begin-transaction ( -- )
     "BEGIN" sql-command ;
@@ -117,139 +110,176 @@ M: postgresql-db commit-transaction ( -- )
 M: postgresql-db rollback-transaction ( -- )
     "ROLLBACK" sql-command ;
 
-: postgresql-type-hash* ( -- assoc )
+SYMBOL: postgresql-counter
-    H{
+: bind-name% ( -- )
-        { SERIAL "serial" }
+    CHAR: $ 0,
-    } ;
+    postgresql-counter [ inc ] keep get 0# ;
 
-: postgresql-type-hash ( -- assoc )
+M: postgresql-db bind% ( spec -- )
+    1, bind-name% ;
+
+: postgresql-make ( class quot -- )
+    >r sql-props r>
+    [ postgresql-counter off ] swap compose
+    { "" { } { } } nmake <postgresql-statement> ;
+
+: create-table-sql ( class -- statement )
+    [
+        "create table " 0% 0%
+        "(" 0%
+        [ ", " 0% ] [
+            dup sql-spec-column-name 0%
+            " " 0%
+            dup sql-spec-type t lookup-type 0%
+            modifiers 0%
+        ] interleave ");" 0%
+    ] postgresql-make ;
+
+: create-function-sql ( class -- statement )
+    [
+        >r remove-id r>
+        "create function add_" 0% dup 0%
+        "(" 0%
+        over [ "," 0% ]
+        [
+            sql-spec-type f lookup-type 0%
+        ] interleave
+        ")" 0%
+        " returns bigint as '" 0%
+
+        "insert into " 0%
+        dup 0%
+        "(" 0%
+        over [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+        ") values(" 0%
+        swap [ ", " 0% ] [ drop bind-name% ] interleave
+        "); " 0%
+        "select currval(''" 0% 0% "_id_seq'');' language sql;" 0%
+    ] postgresql-make ;
+
+M: postgresql-db create-sql-statement ( class -- seq )
+    [
+        [ create-table-sql , ] keep
+        dup db-columns find-primary-key native-id?
+        [ create-function-sql , ] [ drop ] if
+    ] { } make ;
+
+: drop-function-sql ( class -- statement )
+    [
+        "drop function add_" 0% 0%
+        "(" 0%
+        remove-id
+        [ ", " 0% ] [ sql-spec-type f lookup-type 0% ] interleave
+        ");" 0%
+    ] postgresql-make ;
+
+: drop-table-sql ( table -- statement )
+    [
+        "drop table " 0% 0% ";" 0% drop
+    ] postgresql-make ;
+
+M: postgresql-db drop-sql-statement ( class -- seq )
+    [
+        [ drop-table-sql , ] keep
+        dup db-columns find-primary-key native-id?
+        [ drop-function-sql , ] [ drop ] if
+    ] { } make ;
+
+M: postgresql-db <insert-native-statement> ( class -- statement )
+    [
+        "select add_" 0% 0%
+        "(" 0%
+        dup find-primary-key 2,
+        remove-id
+        [ ", " 0% ] [ bind% ] interleave
+        ");" 0%
+    ] postgresql-make ;
+
+M: postgresql-db <insert-assigned-statement> ( class -- statement )
+    [
+        "insert into " 0% 0%
+        "(" 0%
+        dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+        ")" 0%
+
+        " values(" 0%
+        [ ", " 0% ] [ bind% ] interleave
+        ");" 0%
+    ] postgresql-make ;
+
+M: postgresql-db insert-tuple* ( tuple statement -- )
+    query-modify-tuple ;
+
+M: postgresql-db <update-tuple-statement> ( class -- statement )
+    [
+        "update " 0% 0%
+        " set " 0%
+        dup remove-id
+        [ ", " 0% ]
+        [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
+        " where " 0%
+        find-primary-key
+        dup sql-spec-column-name 0% " = " 0% bind%
+    ] postgresql-make ;
+
+M: postgresql-db <delete-tuple-statement> ( class -- statement )
+    [
+        "delete from " 0% 0%
+        " where " 0%
+        find-primary-key
+        dup sql-spec-column-name 0% " = " 0% bind%
+    ] postgresql-make ;
+
+M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
+    [
+    ! tuple columns table
+        "select " 0%
+        over [ ", " 0% ]
+        [ dup sql-spec-column-name 0% 2, ] interleave
+
+        " from " 0% 0%
+        [ sql-spec-slot-name swap get-slot-named ] with subset
+        " where " 0%
+        [ ", " 0% ]
+        [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
+        ";" 0%
+    ] postgresql-make ;
+
+M: postgresql-db type-table ( -- hash )
     H{
-        { INTEGER "integer" }
+        { +native-id+ "integer" }
-        { SERIAL "integer" }
         { TEXT "text" }
         { VARCHAR "varchar" }
+        { INTEGER "integer" }
         { DOUBLE "real" }
+        { TIMESTAMP "timestamp" }
     } ;
 
-: enquote ( str -- newstr ) "(" swap ")" 3append ;
+M: postgresql-db create-type-table ( -- hash )
-
-: postgresql-type ( str n/str  -- newstr )
-    " " swap number>string* enquote 3append ;
-
-: >sql-type* ( obj -- str )
-    dup pair? [
-        first2 >r >sql-type* r> postgresql-type
-    ] [
-        dup postgresql-type-hash* at* [
-            nip
-        ] [
-            drop >sql-type
-        ] if
-    ] if ;
-
-M: postgresql-db >sql-type ( hash obj -- str )
-    dup pair? [
-        first2 >r >sql-type r> postgresql-type
-    ]  [
-        postgresql-type-hash at* [
-            no-sql-type
-        ] unless
-    ] if ;
-
-: insert-function ( columns table -- sql )
-    [
-        >r remove-id r>
-        "create function add_" % dup %
-        "(" %
-        over [ "," % ]
-        [ third dup array? [ first ] when >sql-type % ] interleave
-        ")" %
-        " returns bigint as '" %
-
-        2dup "insert into " %
-        %
-        "(" %
-        dup [ ", " % ] [ second % ] interleave
-        ") " %
-        " values (" %
-        length [1,b] [ ", " % ] [ "$" % # ] interleave
-        "); " %
-
-        "select currval(''" % % "_id_seq'');' language sql;" %
-        drop
-    ] "" make ;
-
-: drop-function ( columns table -- sql )
-    [
-        >r remove-id r>
-        "drop function add_" % %
-        "(" %
-        [ "," % ] [ third >sql-type % ] interleave
-        ")" %
-    ] "" make ;
-
-M: postgresql-db create-sql ( columns table -- seq )
-    [
-        [
-            2dup
-            "create table " % %
-            " (" % [ ", " % ] [
-                dup second % " " %
-                dup third >sql-type* % " " %
-                sql-modifiers " " join %
-            ] interleave "); " %
-        ] "" make ,
-
-        over native-id? [ insert-function , ] [ 2drop ] if
-    ] { } make ;
-
-M: postgresql-db drop-sql ( columns table -- seq )
-    [
-        [
-            dup "drop table " % % ";" %
-        ] "" make ,
-        over native-id? [ drop-function , ] [ 2drop ] if
-    ] { } make ;
-
-M: postgresql-db insert-sql* ( columns table -- slot-names sql )
-    [
-        "select add_" % %
-        "(" %
-        length [1,b] [ ", " % ] [ "$" % # ] interleave
-        ")" %
-    ] "" make ;
-
-M: postgresql-db update-sql* ( columns table -- slot-names sql )
-    [
-        "update " %
-        %
-        " set " %
-        dup remove-id
-        dup length [1,b] swap 2array flip
-        [ ", " % ] [ first2 second % " = $" % # ] interleave
-        " where " %
-        [ primary-key? ] find nip second dup % " = $" % length 2 + #
-    ] "" make ;
-
-M: postgresql-db delete-sql* ( columns table -- slot-names sql )
-    [
-        "delete from " %
-        %
-        " where " %
-        first second % " = $1" %
-    ] "" make ;
-
-M: postgresql-db select-sql ( columns table -- slot-names sql )
-    drop ;
-
-M: postgresql-db tuple>params ( columns tuple -- obj )
-    [ >r dup third swap first r> get-slot-named swap ]
-    curry { } map>assoc ;
-    
-: postgresql-db-modifiers ( -- hashtable )
     H{
-        { +native-id+ "not null primary key" }
+        { +native-id+ "serial primary key" }
+    } ;
+
+: postgresql-compound ( str n -- newstr )
+    over {
+        { "default" [ first number>string join-space ] }
+        { "varchar" [ first number>string paren append ] }
+        { "references" [
+                first2 >r [ unparse join-space ] keep db-columns r>
+                swap [ sql-spec-slot-name = ] with find nip
+                sql-spec-column-name paren append
+            ] }
+        [ "no compound found" 3array throw ]
+    } case ;
+
+M: postgresql-db compound-modifier ( str seq -- newstr )
+    postgresql-compound ;
+    
+M: postgresql-db modifier-table ( -- hashtable )
+    H{
+        { +native-id+ "primary key" }
         { +assigned-id+ "primary key" }
+        { +foreign-id+ "references" }
         { +autoincrement+ "autoincrement" }
         { +unique+ "unique" }
         { +default+ "default" }
@@ -257,13 +287,5 @@ M: postgresql-db tuple>params ( columns tuple -- obj )
         { +not-null+ "not null" }
     } ;
 
-M: postgresql-db sql-modifiers* ( modifiers -- str )
+M: postgresql-db compound-type ( str n -- newstr )
-    postgresql-db-modifiers swap [
+    postgresql-compound ;
-        dup array? [
-            first2
-            >r swap at r> number>string*
-            " " swap 3append
-        ] [
-            swap at
-        ] if
-    ] with map [ ] subset ;

extra/db/sqlite/lib/lib.factor

@@ -78,7 +78,8 @@ IN: db.sqlite.lib
         { TEXT [ sqlite-bind-text-by-name ] }
         { VARCHAR [ sqlite-bind-text-by-name ] }
         { DOUBLE [ sqlite-bind-double-by-name ] }
-        { SERIAL [ sqlite-bind-int-by-name ] }
+        { TIMESTAMP [ sqlite-bind-double-by-name ] }
+        { +native-id+ [ sqlite-bind-int-by-name ] }
         ! { NULL [ sqlite-bind-null-by-name ] }
         [ no-sql-type ]
     } case ;
@@ -102,6 +103,8 @@ IN: db.sqlite.lib
         { BIG_INTEGER [ sqlite3_column_int64 ] }
         { TEXT [ sqlite3_column_text ] }
         { DOUBLE [ sqlite3_column_double ] }
+        { TIMESTAMP [ sqlite3_column_double ] }
+        [ no-sql-type ]
     } case ;
 
 ! TODO

extra/db/sqlite/sqlite-tests.factor

@@ -1,6 +1,6 @@
 USING: io io.files io.launcher kernel namespaces
 prettyprint tools.test db.sqlite db sequences
-continuations db.types ;
+continuations db.types db.tuples unicode.case ;
 IN: temporary
 
 : test.db "extra/db/sqlite/test.db" resource-path ;
@@ -89,3 +89,158 @@ IN: temporary
         "select * from person" sql-query length
     ] with-sqlite
 ] unit-test
+
+! TEST TUPLE DB
+
+TUPLE: puppy id name age ;
+: <puppy> ( name age -- puppy )
+    { set-puppy-name set-puppy-age } puppy construct ;
+
+puppy "PUPPY" {
+    { "id" "ID" +native-id+ +not-null+ }
+    { "name" "NAME" { VARCHAR 256 } }
+    { "age" "AGE" INTEGER }
+} define-persistent
+
+TUPLE: kitty id name age ;
+: <kitty> ( name age -- kitty )
+    { set-kitty-name set-kitty-age } kitty construct ;
+
+kitty "KITTY" {
+    { "id" "ID" INTEGER +assigned-id+ }
+    { "name" "NAME" TEXT }
+    { "age" "AGE" INTEGER }
+} define-persistent
+
+TUPLE: basket id puppies kitties ;
+basket "BASKET"
+{
+    { "id" "ID" +native-id+ +not-null+ }
+    { "location" "LOCATION" TEXT }
+    { "puppies" { +has-many+ puppy } }
+    { "kitties" { +has-many+ kitty } }
+} define-persistent
+
+! Create table
+[
+    "create table puppy(id integer primary key not null, name varchar, age integer);"
+] [
+    T{ sqlite-db } db [
+        puppy dup db-columns swap db-table create-sql >lower
+    ] with-variable
+] unit-test
+
+[
+    "create table kitty(id integer primary key, name text, age integer);"
+] [
+    T{ sqlite-db } db [
+        kitty dup db-columns swap db-table create-sql >lower
+    ] with-variable
+] unit-test
+
+[
+    "create table basket(id integer primary key not null, location text);"
+] [
+    T{ sqlite-db } db [
+        basket dup db-columns swap db-table create-sql >lower
+    ] with-variable
+] unit-test
+
+! Drop table
+[
+    "drop table puppy;"
+] [
+    T{ sqlite-db } db [
+        puppy db-table drop-sql >lower
+    ] with-variable
+] unit-test
+
+[
+    "drop table kitty;"
+] [
+    T{ sqlite-db } db [
+        kitty db-table drop-sql >lower
+    ] with-variable
+] unit-test
+
+[
+    "drop table basket;"
+] [
+    T{ sqlite-db } db [
+        basket db-table drop-sql >lower
+    ] with-variable
+] unit-test
+
+! Insert
+[
+    "insert into puppy(name, age) values(:name, :age);"
+] [
+    T{ sqlite-db } db [
+        puppy dup db-columns swap db-table insert-sql* >lower
+    ] with-variable
+] unit-test
+
+[
+    "insert into kitty(id, name, age) values(:id, :name, :age);"
+] [
+    T{ sqlite-db } db [
+        kitty dup db-columns swap db-table insert-sql* >lower
+    ] with-variable
+] unit-test
+
+! Update
+[
+    "update puppy set name = :name, age = :age where id = :id"
+] [
+    T{ sqlite-db } db [
+        puppy dup db-columns swap db-table update-sql* >lower
+    ] with-variable
+] unit-test
+
+[
+    "update kitty set name = :name, age = :age where id = :id"
+] [
+    T{ sqlite-db } db [
+        kitty dup db-columns swap db-table update-sql* >lower
+    ] with-variable
+] unit-test
+
+! Delete
+[
+    "delete from puppy where id = :id"
+] [
+    T{ sqlite-db } db [
+        puppy dup db-columns swap db-table delete-sql* >lower
+    ] with-variable
+] unit-test
+
+[
+    "delete from kitty where id = :id"
+] [
+    T{ sqlite-db } db [
+        kitty dup db-columns swap db-table delete-sql* >lower
+    ] with-variable
+] unit-test
+
+! Select
+[
+    "select from puppy id, name, age where name = :name;"
+    {
+        T{
+            sql-spec
+            f
+            "id"
+            "ID"
+            +native-id+
+            { +not-null+ }
+            +native-id+
+        }
+        T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
+        T{ sql-spec f "age" "AGE" INTEGER { } f }
+    }
+] [
+    T{ sqlite-db } db [
+        T{ puppy f f "Mr. Clunkers" }
+        select-sql >r >lower r>
+    ] with-variable
+] unit-test

extra/db/sqlite/sqlite.factor

@@ -4,7 +4,7 @@ USING: alien arrays assocs classes compiler db
 hashtables io.files kernel math math.parser namespaces
 prettyprint sequences strings tuples alien.c-types
 continuations db.sqlite.lib db.sqlite.ffi db.tuples
-words combinators.lib db.types ;
+words combinators.lib db.types combinators tools.walker ;
 IN: db.sqlite
 
 TUPLE: sqlite-db path ;
@@ -23,7 +23,6 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
     >r <sqlite-db> r> with-db ; inline
 
 TUPLE: sqlite-statement ;
-C: <sqlite-statement> sqlite-statement
 
 TUPLE: sqlite-result-set has-more? ;
 
@@ -31,9 +30,15 @@ M: sqlite-db <simple-statement> ( str -- obj )
     <prepared-statement> ;
 
 M: sqlite-db <prepared-statement> ( str -- obj )
-    db get db-handle over sqlite-prepare
+    db get db-handle 
-    { set-statement-sql set-statement-handle } statement construct
+    {
-    <sqlite-statement> [ set-delegate ] keep ;
+        set-statement-sql
+        set-statement-in-params
+        set-statement-out-params
+        set-statement-handle
+    } statement construct
+    dup statement-handle over statement-sql sqlite-prepare
+    sqlite-statement construct-delegate ;
 
 M: sqlite-statement dispose ( statement -- )
     statement-handle sqlite-finalize ;
@@ -41,10 +46,11 @@ M: sqlite-statement dispose ( statement -- )
 M: sqlite-result-set dispose ( result-set -- )
     f swap set-result-set-handle ;
 
-: sqlite-bind ( triples handle -- )
+: sqlite-bind ( specs handle -- )
-    swap [ first3 sqlite-bind-type ] with each ;
+break
+    swap [ sqlite-bind-type ] with each ;
 
-M: sqlite-statement bind-statement* ( triples statement -- )
+M: sqlite-statement bind-statement* ( obj statement -- )
     statement-handle sqlite-bind ;
 
 M: sqlite-statement reset-statement ( statement -- )
@@ -54,8 +60,8 @@ M: sqlite-statement reset-statement ( statement -- )
     db get db-handle sqlite3_last_insert_rowid
     dup zero? [ "last-id failed" throw ] when ;
 
-M: sqlite-statement insert-statement ( statement -- id )
+M: sqlite-statement insert-tuple* ( tuple statement -- )
-    execute-statement last-insert-id ;
+    execute-statement last-insert-id swap set-primary-key ;
 
 M: sqlite-result-set #columns ( result-set -- n )
     result-set-handle sqlite-#columns ;
@@ -74,6 +80,7 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
     sqlite-result-set-has-more? ;
 
 M: sqlite-statement query-results ( query -- result-set )
+break
     dup statement-handle sqlite-result-set <result-set>
     dup advance-row ;
 
@@ -86,78 +93,85 @@ M: sqlite-db commit-transaction ( -- )
 M: sqlite-db rollback-transaction ( -- )
     "ROLLBACK" sql-command ;
 
-M: sqlite-db create-sql ( columns table -- sql )
+: sqlite-make ( class quot -- )
-    [
+    >r sql-props r>
-        "create table " % %
+    { "" { } { } } nmake <simple-statement> ;
-        " (" % [ ", " % ] [
-            dup second % " " %
-            dup third >sql-type % " " %
-            sql-modifiers " " join %
-        ] interleave ")" %
-    ] "" make ;
 
-M: sqlite-db drop-sql ( columns table -- sql )
+M: sqlite-db create-sql-statement ( class -- statement )
     [
-        "drop table " % %
+        "create table " 0% 0%
-        drop
+        "(" 0% [ ", " 0% ] [
-    ] "" make ;
+            dup sql-spec-column-name 0%
+            " " 0%
+            dup sql-spec-type t lookup-type 0%
+            modifiers 0%
+        ] interleave ");" 0%
+    ] sqlite-make ;
 
-M: sqlite-db insert-sql* ( columns table -- sql )
+M: sqlite-db drop-sql-statement ( class -- statement )
     [
-        "insert into " %
+        "drop table " 0% 0% ";" 0% drop
-        %
+    ] sqlite-make ;
-        "(" %
-        dup [ ", " % ] [ second % ] interleave
-        ") " %
-        " values (" %
-        [ ", " % ] [ ":" % second % ] interleave
-        ")" %
-    ] "" make ;
 
-: where-primary-key% ( columns -- )
+M: sqlite-db <insert-native-statement> ( tuple -- statement )
-    " where " %
-    [ primary-key? ] find nip second dup % " = :" % % ;
-
-M: sqlite-db update-sql* ( columns table -- sql )
     [
-        "update " %
+        "insert into " 0% 0%
-        %
+        "(" 0%
-        " set " %
+        maybe-remove-id
+        dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+        ") values(" 0%
+        [ ", " 0% ] [ bind% ] interleave
+        ");" 0%
+    ] sqlite-make ;
+
+M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
+    <insert-native-statement> ;
+
+: where-primary-key% ( specs -- )
+    " where " 0%
+    find-primary-key sql-spec-column-name dup 0% " = " 0% bind% ;
+
+M: sqlite-db <update-tuple-statement> ( class -- statement )
+    [
+        "update " 0%
+        0%
+        " set " 0%
         dup remove-id
-        [ ", " % ] [ second dup % " = :" % % ] interleave
+        [ ", " 0% ] [ sql-spec-column-name dup 0% " = " 0% bind% ] interleave
         where-primary-key%
-    ] "" make ;
+    ] sqlite-make ;
 
-M: sqlite-db delete-sql* ( columns table -- sql )
+M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
     [
-        "delete from " %
+        "delete from " 0% 0%
-        %
+        " where " 0%
-        " where " %
+        find-primary-key
-        first second dup % " = :" % %
+        sql-spec-column-name dup 0% " = " 0% bind%
-    ] "" make ;
+    ] sqlite-make ;
 
-: select-interval ( interval name -- )
+! : select-interval ( interval name -- ) ;
-    ;
+! : select-sequence ( seq name -- ) ;
 
-: select-sequence ( seq name -- )
+M: sqlite-db bind% ( spec -- )
-    ;
+    dup 1, sql-spec-column-name ":" swap append 0% ;
+    ! dup 1, sql-spec-column-name
+    ! dup 0% " = " 0% ":" swap append 0% ;
 
-M: sqlite-db select-sql ( columns table -- sql )
+M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
     [
-        "select ROWID, " %
+        "select " 0%
-        over [ ", " % ] [ second % ] interleave
+        over [ ", " 0% ]
-        " from " % %
+        [ dup sql-spec-column-name 0% 2, ] interleave
-        " where " %
-    ] "" make ;
 
-M: sqlite-db tuple>params ( columns tuple -- obj )
+        " from " 0% 0%
-    [
+        [ sql-spec-slot-name swap get-slot-named ] with subset
-        >r [ second ":" swap append ] keep r>
+        " where " 0%
-        dupd >r first r> get-slot-named swap
+        [ ", " 0% ]
-        third 3array
+        [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
-    ] curry map ;
+        ";" 0%
+    ] sqlite-make ;
 
-: sqlite-db-modifiers ( -- hashtable )
+M: sqlite-db modifier-table ( -- hashtable )
     H{
         { +native-id+ "primary key" }
         { +assigned-id+ "primary key" }
@@ -168,32 +182,27 @@ M: sqlite-db tuple>params ( columns tuple -- obj )
         { +not-null+ "not null" }
     } ;
 
-M: sqlite-db sql-modifiers* ( modifiers -- str )
+M: sqlite-db compound-modifier ( str obj -- newstr )
-    sqlite-db-modifiers swap [
+    compound-type ;
-        dup array? [
-            first2
-            >r swap at r> number>string*
-            " " swap 3append
-        ] [
-            swap at
-        ] if
-    ] with map [ ] subset ;
 
-: sqlite-type-hash ( -- assoc )
+M: sqlite-db compound-type ( str seq -- newstr )
+    over {
+        { "default" [ first number>string join-space ] }
+        [ 2drop ] !  "no sqlite compound data type" 3array throw ]
+    } case ;
+
+M: sqlite-db type-table ( -- assoc )
     H{
+        { +native-id+ "integer primary key" }
         { INTEGER "integer" }
-        { SERIAL "integer" }
         { TEXT "text" }
         { VARCHAR "text" }
+        { TIMESTAMP "timestamp" }
         { DOUBLE "real" }
     } ;
 
-M: sqlite-db >sql-type ( obj -- str )
+M: sqlite-db create-type-table
-    dup pair? [
+    type-table ;
-        first >sql-type
-    ] [
-        sqlite-type-hash at* [ T{ no-sql-type } throw ] unless
-    ] if ;
 
 ! HOOK: get-column-value ( n result-set type -- )
 ! M: sqlite get-column-value { { "TEXT" get-text-column } { 

extra/db/tuples/tuples-tests.factor

@@ -1,70 +1,118 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io.files kernel tools.test db db.sqlite db.tuples
+USING: io.files kernel tools.test db db.tuples
-db.types continuations namespaces db.postgresql math ;
+db.types continuations namespaces db.postgresql math
-! tools.time ;
+prettyprint tools.walker db.sqlite ;
 IN: temporary
 
-TUPLE: person the-id the-name the-number real ;
+TUPLE: person the-id the-name the-number the-real ;
 : <person> ( name age real -- person )
     {
         set-person-the-name
         set-person-the-number
-        set-person-real
+        set-person-the-real
     } person construct ;
 
-: <assigned-person> ( id name number real -- obj )
+: <assigned-person> ( id name number the-real -- obj )
     <person> [ set-person-the-id ] keep ;
 
-SYMBOL: the-person
+SYMBOL: the-person1
+SYMBOL: the-person2
 
 : test-tuples ( -- )
     [ person drop-table ] [ drop ] recover
     [ ] [ person create-table ] unit-test
     
-    [  ] [ the-person get insert-tuple ] unit-test
+    [  ] [ the-person1 get insert-tuple ] unit-test
 
-    [ 1 ] [ the-person get person-the-id ] unit-test
+    [ 1 ] [ the-person1 get person-the-id ] unit-test
 
-    200 the-person get set-person-the-number
+    200 the-person1 get set-person-the-number
 
-    [ ] [ the-person get update-tuple ] unit-test
+    [ ] [ the-person1 get update-tuple ] unit-test
 
-    [ ] [ the-person get delete-tuple ] unit-test
+    [ T{ person f 1 "billy" 200 3.14 } ]
-    ; ! 1 [ ] [ person drop-table ] unit-test ;
+    [ T{ person f 1 } select-tuple ] unit-test
+    [ ] [ the-person2 get insert-tuple ] unit-test
+    [
+        {
+            T{ person f 1 "billy" 200 3.14 }
+            T{ person f 2 "johnny" 10 3.14 }
+        }
+    ] [ T{ person f f f f 3.14 } select-tuples ] unit-test
+
+    [ ] [ the-person1 get delete-tuple ] unit-test
+    [ f ] [ T{ person f 1 } select-tuple ] unit-test
+    [ ] [ person drop-table ] unit-test ;
 
 : test-sqlite ( -- )
-    "tuples-test.db" resource-path <sqlite-db> [
+    "tuples-test.db" resource-path sqlite-db [
         test-tuples
     ] with-db ;
 
 : test-postgresql ( -- )
-    "localhost" "postgres" "" "factor-test" <postgresql-db> [
+    { "localhost" "postgres" "" "factor-test" } postgresql-db [
         test-tuples
     ] with-db ;
 
 person "PERSON"
 {
-    { "the-id" "ID" SERIAL +native-id+ }
+    { "the-id" "ID" +native-id+ }
     { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
     { "the-number" "AGE" INTEGER { +default+ 0 } }
-    { "real" "REAL" DOUBLE { +default+ 0.3 } }
+    { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
 } define-persistent
 
-"billy" 10 3.14 <person> the-person set
+"billy" 10 3.14 <person> the-person1 set
+"johnny" 10 3.14 <person> the-person2 set
 
 ! test-sqlite
- test-postgresql
+test-postgresql
 
-! person "PERSON"
+person "PERSON"
-! {
+{
-    ! { "the-id" "ID" INTEGER +assigned-id+ }
+    { "the-id" "ID" INTEGER +assigned-id+ }
-    ! { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
+    { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
-    ! { "the-number" "AGE" INTEGER { +default+ 0 } }
+    { "the-number" "AGE" INTEGER { +default+ 0 } }
-    ! { "real" "REAL" DOUBLE { +default+ 0.3 } }
+    { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
-! } define-persistent
+} define-persistent
 
-! 1 "billy" 20 6.28 <assigned-person> the-person set
+1 "billy" 10 3.14 <assigned-person> the-person1 set
+2 "johnny" 10 3.14 <assigned-person> the-person2 set
 
 ! test-sqlite
-! test-postgresql
+test-postgresql
+
+TUPLE: paste n summary author channel mode contents timestamp annotations ;
+TUPLE: annotation n paste-id summary author mode contents ;
+
+paste "PASTE"
+{
+    { "n" "ID" +native-id+ }
+    { "summary" "SUMMARY" TEXT }
+    { "author" "AUTHOR" TEXT }
+    { "channel" "CHANNEL" TEXT }
+    { "mode" "MODE" TEXT }
+    { "contents" "CONTENTS" TEXT }
+    { "date" "DATE" TIMESTAMP }
+    { "annotations" { +has-many+ annotation } }
+} define-persistent
+
+annotation "ANNOTATION"
+{
+    { "n" "ID" +native-id+ }
+    { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
+    { "summary" "SUMMARY" TEXT }
+    { "author" "AUTHOR" TEXT }
+    { "mode" "MODE" TEXT }
+    { "contents" "CONTENTS" TEXT }
+} define-persistent
+
+{ "localhost" "postgres" "" "factor-test" } postgresql-db [
+    [ paste drop-table ] [ drop ] recover
+    [ annotation drop-table ] [ drop ] recover
+    [ paste drop-table ] [ drop ] recover
+    [ annotation drop-table ] [ drop ] recover
+    [ ] [ paste create-table ] unit-test
+    [ ] [ annotation create-table ] unit-test
+] with-db

extra/db/tuples/tuples.factor

@@ -1,115 +1,100 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs classes db kernel namespaces
-tuples words sequences slots slots.private math
+tuples words sequences slots math
-math.parser io prettyprint db.types continuations ;
+math.parser io prettyprint db.types continuations
+mirrors sequences.lib tools.walker combinators.lib ;
 IN: db.tuples
 
-: db-columns ( class -- obj ) "db-columns" word-prop ;
+: define-persistent ( class table columns -- )
+    >r dupd "db-table" set-word-prop dup r>
+    [ relation? ] partition swapd
+    dupd [ spec>tuple ] with map
+    "db-columns" set-word-prop
+    "db-relations" set-word-prop ;
+
 : db-table ( class -- obj ) "db-table" word-prop ;
+: db-columns ( class -- obj ) "db-columns" word-prop ;
+: db-relations ( class -- obj ) "db-relations" word-prop ;
 
-TUPLE: no-slot-named ;
+: set-primary-key ( key tuple -- )
-: no-slot-named ( -- * ) T{ no-slot-named } throw ;
+    [
+        class db-columns find-primary-key sql-spec-slot-name
+    ] keep set-slot-named ;
 
-: slot-spec-named ( str class -- slot-spec )
+! returns a sequence of prepared-statements
-    "slots" word-prop [ slot-spec-name = ] with find nip
+HOOK: create-sql-statement db ( class -- obj )
-    [ no-slot-named ] unless* ;
+HOOK: drop-sql-statement db ( class -- obj )
 
-: offset-of-slot ( str obj -- n )
+HOOK: <insert-native-statement> db ( tuple -- obj )
-    class slot-spec-named slot-spec-offset ;
+HOOK: <insert-assigned-statement> db ( tuple -- obj )
 
-: get-slot-named ( str obj -- value )
+HOOK: <update-tuple-statement> db ( tuple -- obj )
-    tuck offset-of-slot [ no-slot-named ] unless* slot ;
+HOOK: <update-tuples-statement> db ( tuple -- obj )
 
-: set-slot-named ( value str obj -- )
+HOOK: <delete-tuple-statement> db ( tuple -- obj )
-    tuck offset-of-slot [ no-slot-named ] unless* set-slot ;
+HOOK: <delete-tuples-statement> db ( tuple -- obj )
 
-: primary-key-spec ( class -- spec )
+HOOK: <select-by-slots-statement> db ( tuple -- tuple )
-    db-columns [ primary-key? ] find nip ;
-    
-: primary-key ( tuple -- obj )
-    dup class primary-key-spec get-slot-named ;
-
-: set-primary-key ( obj tuple -- )
-    [ class primary-key-spec first ] keep
-    set-slot-named ;
-
-: cache-statement ( columns class assoc quot -- statement )
-    [ db-table dupd ] swap
-    [ <prepared-statement> ] 3compose cache nip ; inline
-
-HOOK: create-sql db ( columns table -- seq )
-HOOK: drop-sql db ( columns table -- seq )
-
-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: insert-tuple* db ( tuple statement -- )
-HOOK: tuple>params db ( columns tuple -- obj )
 
+: resulting-tuple ( row out-params -- tuple )
+    dup first sql-spec-class construct-empty [
+        [
+            >r [ sql-spec-type sql-type>factor-type ] keep
+            sql-spec-slot-name r> set-slot-named
+        ] curry 2each
+    ] keep ;
 
-HOOK: make-slot-names* db ( quot -- seq )
+: query-tuples ( statement -- seq )
-HOOK: column-slot-name% db ( spec -- )
+    [ statement-out-params ] keep query-results [
-HOOK: column-bind-name% db ( spec -- )
+        [ sql-row swap resulting-tuple ] with query-map
+    ] with-disposal ;
  
-: make-slots-names ( quot -- seq str )
+: query-modify-tuple ( tuple statement -- )
-    [ make-slot-names* ] "" make ; inline
+    [ query-results [ sql-row ] with-disposal ] keep
-: slot-name% ( seq -- ) first % ;
+    statement-out-params rot [
-: column-name% ( seq -- ) second % ;
+        >r [ sql-spec-type sql-type>factor-type ] keep
-: column-type% ( seq -- ) third % ;
+        sql-spec-slot-name r> set-slot-named
+    ] curry 2each ;
 
-: insert-sql ( columns class -- statement )
+: sql-props ( class -- columns table )
-    db get db-insert-statements [ insert-sql* ] cache-statement ;
+    dup db-columns swap db-table ;
 
-: update-sql ( columns class -- statement )
+: create-table ( class -- ) create-sql-statement execute-statement ;
-    db get db-update-statements [ update-sql* ] cache-statement ;
+: drop-table ( class -- ) drop-sql-statement execute-statement ;
 
-: delete-sql ( columns class -- statement )
+: insert-native ( tuple -- )
-    db get db-delete-statements [ delete-sql* ] cache-statement ;
+    dup class <insert-native-statement>
+    [ bind-tuple ] 2keep insert-tuple* ;
 
-
+: insert-assigned ( tuple -- )
-: tuple-statement ( columns tuple quot -- statement )
+    dup class <insert-assigned-statement>
-    >r [ tuple>params ] 2keep class r> call
+    [ bind-tuple ] keep execute-statement ;
-    2dup . .
-    [ bind-statement ] keep ;
-
-: make-tuple-statement ( tuple columns-quot statement-quot -- statement )
-    >r [ class db-columns ] swap compose keep
-    r> tuple-statement ;
-
-: do-tuple-statement ( tuple columns-quot statement-quot -- )
-    make-tuple-statement execute-statement ;
-
-: create-table ( class -- )
-    dup db-columns swap db-table create-sql sql-command ;
-    
-: drop-table ( class -- )
-    dup db-columns swap db-table drop-sql sql-command ;
 
 : insert-tuple ( tuple -- )
-    [
+    dup class db-columns find-primary-key assigned-id? [
-        [ maybe-remove-id ] [ insert-sql ]
+        insert-assigned
-        make-tuple-statement insert-statement
+    ] [
-    ] keep set-primary-key ;
+        insert-native
+    ] if ;
 
 : update-tuple ( tuple -- )
-    [ ] [ update-sql ] do-tuple-statement ;
+    dup class <update-tuple-statement>
+    [ bind-tuple ] keep execute-statement ;
+
+: update-tuples ( seq -- )
+    <update-tuples-statement> execute-statement ;
 
 : delete-tuple ( tuple -- )
-    [ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ;
+    dup class <delete-tuple-statement>
+    [ bind-tuple ] keep execute-statement ;
 
-: select-tuple ( tuple -- )
+: setup-select ( tuple -- statement )
-    [ select-sql ] keep do-query ;
+    dup dup class <select-by-slots-statement>
+    [ bind-tuple ] keep ;
 
-: persist ( tuple -- )
+: select-tuples ( tuple -- tuple ) setup-select query-tuples ;
-    dup primary-key [ update-tuple ] [ insert-tuple ] if ;
+: select-tuple ( tuple -- tuple/f ) select-tuples ?first ;
-
-: define-persistent ( class table columns -- )
-    >r dupd "db-table" set-word-prop r>
-    "db-columns" set-word-prop ;
-
-: define-relation ( spec -- )
-    drop ;

extra/db/types/types.factor

@@ -1,21 +1,50 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs db kernel math math.parser
-sequences continuations ;
+sequences continuations sequences.deep sequences.lib
+words namespaces tools.walker slots slots.private classes
+mirrors tuples combinators ;
 IN: db.types
 
+HOOK: modifier-table db ( -- hash )
+HOOK: compound-modifier db ( str seq -- hash )
+HOOK: type-table db ( -- hash )
+HOOK: create-type-table db ( -- hash )
+HOOK: compound-type db ( str n -- hash )
+
+TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
 ! ID is the Primary key
+! +native-id+ can be a columns type or a modifier
 SYMBOL: +native-id+
+! +assigned-id+ can only be a modifier
 SYMBOL: +assigned-id+
 
+: (primary-key?) ( obj -- ? )
+    { +native-id+ +assigned-id+ } member? ;
+
 : primary-key? ( spec -- ? )
-    [ { +native-id+ +assigned-id+ } member? ] contains? ;
+    sql-spec-primary-key (primary-key?) ;
 
-: contains-id? ( columns id -- ? )
+: normalize-spec ( spec -- )
-    swap [ member? ] with contains? ;
+    dup sql-spec-type dup (primary-key?) [
+        swap set-sql-spec-primary-key
+    ] [
+        drop dup sql-spec-modifiers [
+            (primary-key?)
+        ] deep-find
+        [ swap set-sql-spec-primary-key ] [ drop ] if*
+    ] if ;
 
-: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ;
+: find-primary-key ( specs -- obj )
-: native-id? ( columns -- ? ) +native-id+ contains-id? ;
+    [ sql-spec-primary-key ] find nip ;
+
+: native-id? ( spec -- ? )
+    sql-spec-primary-key +native-id+ = ;
+
+: assigned-id? ( spec -- ? )
+    sql-spec-primary-key +assigned-id+ = ;
+
+SYMBOL: +foreign-id+
 
 ! Same concept, SQLite has autoincrement, PostgreSQL has serial
 SYMBOL: +autoincrement+
@@ -28,40 +57,168 @@ SYMBOL: +not-null+
 
 SYMBOL: +has-many+
 
-SYMBOL: SERIAL
+: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
-SYMBOL: INTEGER
-SYMBOL: DOUBLE
-SYMBOL: BOOLEAN
 
+SYMBOL: INTEGER
+SYMBOL: BIG_INTEGER
+SYMBOL: DOUBLE
+SYMBOL: REAL
+SYMBOL: BOOLEAN
 SYMBOL: TEXT
 SYMBOL: VARCHAR
-
 SYMBOL: TIMESTAMP
 SYMBOL: DATE
 
-SYMBOL: BIG_INTEGER
+: spec>tuple ( class spec -- tuple )
+    [ ?first3 ] keep 3 ?tail*
+    {
+        set-sql-spec-class
+        set-sql-spec-slot-name
+        set-sql-spec-column-name
+        set-sql-spec-type
+        set-sql-spec-modifiers
+    } sql-spec construct
+    dup normalize-spec ;
+
+: sql-type-hash ( -- assoc )
+    H{
+        { INTEGER "integer" }
+        { TEXT "text" }
+        { VARCHAR "varchar" }
+        { DOUBLE "real" }
+        { TIMESTAMP "timestamp" }
+    } ;
 
 TUPLE: no-sql-type ;
 : no-sql-type ( -- * ) T{ no-sql-type } throw ;
 
-HOOK: sql-modifiers* db ( modifiers -- str )
+TUPLE: no-sql-modifier ;
-HOOK: >sql-type db ( obj -- str )
+: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ;
-
-! HOOK: >factor-type db ( obj -- obj )
 
 : number>string* ( n/str -- str )
     dup number? [ number>string ] when ;
 
-: maybe-remove-id ( columns -- obj )
+: maybe-remove-id ( specs -- obj )
-    [ +native-id+ swap member? not ] subset ;
+    [ native-id? not ] subset ;
 
-: remove-id ( columns -- obj )
+: remove-relations ( specs -- newcolumns )
-    [ primary-key? not ] subset ;
+    [ relation? not ] subset ;
 
-: sql-modifiers ( spec -- seq )
+: remove-id ( specs -- obj )
-    3 tail sql-modifiers* ;
+    [ sql-spec-primary-key not ] subset ;
 
 ! SQLite Types: http://www.sqlite.org/datatype3.html
 ! NULL INTEGER REAL TEXT BLOB
 ! PostgreSQL Types:
 ! http://developer.postgresql.org/pgdocs/postgres/datatype.html
+
+: lookup-modifier ( obj -- str )
+    dup array? [
+        unclip lookup-modifier swap compound-modifier
+    ] [
+        modifier-table at*
+        [ "unknown modifier" throw ] unless
+    ] if ;
+
+: lookup-type* ( obj -- str )
+    dup array? [
+        first lookup-type*
+    ] [
+        type-table at*
+        [ no-sql-type ] unless
+    ] if ;
+
+: lookup-create-type ( obj -- str )
+    dup array? [
+        unclip lookup-create-type swap compound-type
+    ] [
+        dup create-type-table at*
+        [ nip ] [ drop lookup-type* ] if
+    ] if ;
+
+: lookup-type ( obj create? -- str )
+    [ lookup-create-type ] [ lookup-type* ] if ;
+
+: single-quote ( str -- newstr )
+    "'" swap "'" 3append ;
+
+: double-quote ( str -- newstr )
+    "\"" swap "\"" 3append ;
+
+: paren ( str -- newstr )
+    "(" swap ")" 3append ;
+
+: join-space ( str1 str2 -- newstr )
+    " " swap 3append ;
+
+: modifiers ( spec -- str )
+    sql-spec-modifiers 
+    [ lookup-modifier ] map " " join
+    dup empty? [ " " swap append ] unless ;
+
+SYMBOL: building-seq 
+: get-building-seq ( n -- seq )
+    building-seq get nth ;
+
+: n, get-building-seq push ;
+: n% get-building-seq push-all ;
+: n# >r number>string r> n% ;
+
+: 0, 0 n, ;
+: 0% 0 n% ;
+: 0# 0 n# ;
+: 1, 1 n, ;
+: 1% 1 n% ;
+: 1# 1 n# ;
+: 2, 2 n, ;
+: 2% 2 n% ;
+: 2# 2 n# ;
+
+: nmake ( quot exemplars -- seqs )
+    dup length dup zero? [ 1+ ] when
+    [
+        [
+            [ drop 1024 swap new-resizable ] 2map
+            [ building-seq set call ] keep
+        ] 2keep >r [ like ] 2map r> firstn 
+    ] with-scope ;
+
+HOOK: bind% db ( spec -- )
+
+TUPLE: no-slot-named ;
+: no-slot-named ( -- * ) T{ no-slot-named } throw ;
+
+: slot-spec-named ( str class -- slot-spec )
+    "slots" word-prop [ slot-spec-name = ] with find nip
+    [ no-slot-named ] unless* ;
+
+: offset-of-slot ( str obj -- n )
+    class slot-spec-named slot-spec-offset ;
+
+: get-slot-named ( str obj -- value )
+    tuck offset-of-slot [ no-slot-named ] unless* slot ;
+
+: set-slot-named ( value str obj -- )
+    tuck offset-of-slot [ no-slot-named ] unless* set-slot ;
+
+: tuple>filled-slots ( tuple -- alist )
+    dup <mirror> mirror-slots [ slot-spec-name ] map
+    swap tuple-slots 2array flip [ nip ] assoc-subset ;
+
+: tuple>params ( specs tuple -- obj )
+    [
+        >r dup sql-spec-type swap sql-spec-slot-name r>
+        get-slot-named swap
+    ] curry { } map>assoc ;
+
+: sql-type>factor-type ( obj type -- obj )
+    dup array? [ first ] when
+    {
+        { +native-id+ [ string>number ] }
+        { INTEGER [ string>number ] }
+        { DOUBLE [ string>number ] }
+        { REAL [ string>number ] }
+        { TEXT [ ] }
+        { VARCHAR [ ] }
+        [ "no conversion from sql type to factor type" throw ]
+    } case ;

extra/http/basic-authentication/basic-authentication.factor

@@ -61,5 +61,5 @@ SYMBOL: realms
   #! Check if the user is authenticated in the given realm
   #! to run the specified quotation. If not, use Basic
   #! Authentication to ask for authorization details.
-  over "Authorization" header-param authorization-ok?
+  over "authorization" header-param authorization-ok?
   [ nip call ] [ drop authentication-error ] if ;

extra/http/server/responders/responders.factor

@@ -77,7 +77,7 @@ SYMBOL: max-post-request
 1024 256 * max-post-request set-global
 
 : content-length ( header -- n )
-    "Content-Length" swap at string>number dup [
+    "content-length" peek-at string>number dup [
         dup max-post-request get > [
             "Content-Length > max-post-request" throw
         ] when
@@ -136,7 +136,7 @@ LOG: log-headers DEBUG
 
 : host ( -- string )
     #! The host the current responder was called from.
-    "Host" header-param ":" split1 drop ;
+    "host" header-param ":" split1 drop ;
 
 : add-responder ( responder -- )
     #! Add a responder object to the list.

extra/io/windows/launcher/launcher.factor

@@ -146,8 +146,8 @@ M: windows-io kill-process* ( handle -- )
 
 : wait-loop ( -- )
     processes get dup assoc-empty?
-    [ drop f nap drop ]
+    [ drop f sleep-until ]
-    [ wait-for-processes [ 100 nap drop ] when ] if ;
+    [ wait-for-processes [ 100 sleep ] when ] if ;
 
 SYMBOL: wait-thread
 

extra/ogg/player/player.factor

@@ -14,7 +14,7 @@ USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays
        sequences libc shuffle alien.c-types system openal math
        namespaces threads shuffle opengl arrays ui.gadgets.worlds
        combinators math.parser ui.gadgets ui.render opengl.gl ui
-       continuations io.files hints combinators.lib sequences.lib ;
+       continuations io.files hints combinators.lib sequences.lib debugger ;
 
 IN: ogg.player
 
@@ -149,7 +149,7 @@ HINTS: yuv>rgb byte-array byte-array ;
     dup player-gadget [
         dup { player-td player-yuv } get-slots theora_decode_YUVout drop
         dup player-rgb over player-yuv yuv>rgb
-        dup player-gadget find-world draw-world
+        dup player-gadget relayout yield
     ] when ;
 
 : num-audio-buffers-processed ( player -- player n )
@@ -177,7 +177,7 @@ HINTS: yuv>rgb byte-array byte-array ;
 : append-audio ( player -- player bool )
     num-audio-buffers-processed {
         { [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }
-        { [ over player-buffers length 2 = over zero? and ] [ 0 sleep drop f ] }
+        { [ over player-buffers length 2 = over zero? and ] [ yield drop f ] }
         { [ t ] [ fill-processed-audio-buffer t ] }
     } cond ;
 
@@ -602,8 +602,7 @@ M: theora-gadget draw-gadget* ( gadget -- )
     parse-remaining-headers
     initialize-decoder
     dup player-gadget [ initialize-gui ] when*
-    [ decode ] [ drop ] recover
+    [ decode ] try
-!    decode
     wait-for-sound
     cleanup
     drop ;

extra/random-tester/random-tester.factor

@@ -1,5 +1,6 @@
 USING: compiler continuations io kernel math namespaces
-prettyprint quotations random sequences vectors ;
+prettyprint quotations random sequences vectors
+compiler.units ;
 USING: random-tester.databank random-tester.safe-words ;
 IN: random-tester
 

extra/sequences/lib/lib-tests.factor

@@ -20,8 +20,6 @@ IN: temporary
 [ 10 ] [ { 1 2 3 4 } [ + ] reduce* ] unit-test
 [ 24 ] [ { 1 2 3 4 } [ * ] reduce* ] unit-test
 
-[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test
-
 [ -4 ] [ 1 -4 [ abs ] higher ] unit-test
 [ 1 ] [ 1 -4 [ abs ] lower ] unit-test
 
@@ -80,4 +78,4 @@ IN: temporary
 { 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
 [ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
 
-[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test
+[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test

extra/sequences/lib/lib.factor

@@ -18,8 +18,9 @@ IN: sequences.lib
 
 : map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
 
-MACRO: nfirst ( n -- )
+MACRO: firstn ( n -- )
-    [ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
+    [ [ swap nth ] curry
+    [ keep ] curry ] map concat [ drop ] compose ;
 
 : prepare-index ( seq quot -- seq n quot )
     >r dup length r> ; inline
@@ -182,6 +183,14 @@ PRIVATE>
 : ?first3 ( seq -- 1st/f 2nd/f 3rd/f ) dup ?first2 rot ?third ; inline
 : ?first4 ( seq -- 1st/f 2nd/f 3rd/f 4th/f ) dup ?first3 roll ?fourth ; inline
 
+USE: continuations
+: ?subseq ( from to seq -- subseq )
+    >r >r 0 max r> r>
+    [ length tuck min >r min r> ] keep subseq ;
+
+: ?head* ( seq n -- seq/f ) (head) ?subseq ;
+: ?tail* ( seq n -- seq/f ) (tail) ?subseq ;
+
 : accumulator ( quot -- quot vec )
     V{ } clone [ [ push ] curry compose ] keep ;
 

extra/tools/threads/threads.factor

@@ -8,7 +8,10 @@ heaps.private system math math.parser ;
 : thread. ( thread -- )
     dup thread-id pprint-cell
     dup thread-name over [ write-object ] with-cell
-    dup thread-state "running" or [ write ] with-cell
+    dup thread-state [
+        [ dup self eq? "running" "yield" ? ] unless*
+        write
+    ] with-cell
     [
         thread-sleep-entry [
             entry-key millis [-] number>string write

extra/ui/cocoa/cocoa.factor

@@ -19,7 +19,7 @@ SYMBOL: stop-after-last-window?
 : event-loop ( -- )
     event-loop? [
         [
-            [ NSApp do-events ui-step 10 sleep ] ui-try
+            [ NSApp do-events ui-step ui-wait ] ui-try
         ] with-autorelease-pool event-loop
     ] when ;
 

extra/ui/gadgets/gadgets.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays hashtables kernel models math namespaces sequences
 quotations math.vectors combinators sorting vectors dlists
-models ;
+models threads ;
 IN: ui.gadgets
 
 TUPLE: rect loc dim ;
@@ -178,13 +178,17 @@ M: array gadget-text*
 
 : forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
 
+SYMBOL: ui-thread
+
+: notify-ui-thread ( -- ) ui-thread get interrupt ;
+
 : layout-queue ( -- queue ) \ layout-queue get ;
 
 : layout-later ( gadget -- )
     #! When unit testing gadgets without the UI running, the
     #! invalid queue is not initialized and we simply ignore
     #! invalidation requests.
-    layout-queue [ push-front ] [ drop ] if* ;
+    layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;
 
 DEFER: relayout
 
@@ -256,11 +260,11 @@ M: gadget layout* drop ;
 
 : queue-graft ( gadget -- )
     { f t } over set-gadget-graft-state
-    graft-queue push-front ;
+    graft-queue push-front notify-ui-thread ;
 
 : queue-ungraft ( gadget -- )
     { t f } over set-gadget-graft-state
-    graft-queue push-front ;
+    graft-queue push-front notify-ui-thread ;
 
 : graft-later ( gadget -- )
     dup gadget-graft-state {

extra/ui/ui.factor

@@ -133,6 +133,9 @@ SYMBOL: ui-hook
 : ui-step ( -- )
     [ notify-queued layout-queued redraw-worlds ] assert-depth ;
 
+: ui-wait ( -- )
+    10 sleep ;
+
 : open-world-window ( world -- )
     dup pref-dim over set-gadget-dim dup relayout graft ui-step ;
 
@@ -155,6 +158,7 @@ M: object close-window
     find-world [ ungraft ] when* ;
 
 : start-ui ( -- )
+    self ui-thread set-global
     restore-windows? [
         restore-windows
     ] [

extra/ui/windows/windows.factor

@@ -15,8 +15,11 @@ TUPLE: windows-ui-backend ;
 : lf>crlf [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
 
 : enum-clipboard ( -- seq )
-    0 [ EnumClipboardFormats win32-error dup dup 0 > ] [ ]
+    0
-    { } unfold nip ;
+    [ EnumClipboardFormats win32-error dup dup 0 > ]
+    [ ]
+    [ drop ]
+    unfold nip ;
 
 : with-clipboard ( quot -- )
     f OpenClipboard win32-error=0/f
@@ -40,13 +43,12 @@ TUPLE: windows-ui-backend ;
 : copy ( str -- )
     lf>crlf [
         string>u16-alien
-        f OpenClipboard win32-error=0/f
         EmptyClipboard win32-error=0/f
         GMEM_MOVEABLE over length 1+ GlobalAlloc
             dup win32-error=0/f
     
         dup GlobalLock dup win32-error=0/f
-        rot dup length memcpy
+        swapd byte-array>memory
         dup GlobalUnlock win32-error=0/f
         CF_UNICODETEXT swap SetClipboardData win32-error=0/f
     ] with-clipboard ;
@@ -72,31 +74,29 @@ SYMBOL: mouse-captured
 : style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
 : ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
 
-: adjust-RECT ( RECT -- )
-    style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
-
-: make-RECT ( width height -- RECT )
-    "RECT" <c-object> [ set-RECT-bottom ] keep [ set-RECT-right ] keep ;
-
-: make-adjusted-RECT ( width height -- RECT )
-    make-RECT dup adjust-RECT ;
-
-: get-RECT-dimensions ( RECT -- width height )
-    [ RECT-right ] keep [ RECT-left - ] keep
-    [ RECT-bottom ] keep RECT-top - ;
-
 : get-RECT-top-left ( RECT -- x y )
     [ RECT-left ] keep RECT-top ;
 
+: get-RECT-dimensions ( RECT -- x y width height )
+    [ get-RECT-top-left ] keep
+    [ RECT-right ] keep [ RECT-left - ] keep
+    [ RECT-bottom ] keep RECT-top - ;
+
 : handle-wm-paint ( hWnd uMsg wParam lParam -- )
     #! wParam and lParam are unused
     #! only paint if width/height both > 0
     3drop window draw-world ;
 
 : handle-wm-size ( hWnd uMsg wParam lParam -- )
-    [ lo-word ] keep hi-word make-RECT get-RECT-dimensions 2array 2nip
+    2nip
+    [ lo-word ] keep hi-word 2array
     dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ui-step ] if ;
 
+: handle-wm-move ( hWnd uMsg wParam lParam -- )
+    2nip
+    [ lo-word ] keep hi-word 2array
+    swap window set-world-loc ;
+
 : wm-keydown-codes ( -- key )
     H{
         { 8 "BACKSPACE" }
@@ -240,7 +240,7 @@ M: windows-ui-backend (close-window)
 
 : mouse-absolute>relative ( lparam handle -- array )
     >r >lo-hi r>
-    0 0 make-RECT [ GetWindowRect win32-error=0/f ] keep
+    "RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
     get-RECT-top-left 2array v- ;
 
 : mouse-event>gesture ( uMsg -- button )
@@ -317,6 +317,7 @@ M: windows-ui-backend (close-window)
                 { [ dup WM_PAINT = ]
                       [ drop 4dup handle-wm-paint DefWindowProc ] }
                 { [ dup WM_SIZE = ]      [ drop handle-wm-size 0 ] }
+                { [ dup WM_MOVE = ]      [ drop handle-wm-move 0 ] }
 
                 ! Keyboard events
                 { [ dup WM_KEYDOWN = over WM_SYSKEYDOWN = or ]
@@ -353,7 +354,7 @@ M: windows-ui-backend (close-window)
     {
         { [ windows get empty? ] [ drop ] }
         { [ dup peek-message? ] [
-            >r [ ui-step 10 sleep ] ui-try
+            >r [ ui-step ui-wait ] ui-try
             r> event-loop
         ] }
         { [ dup MSG-message WM_QUIT = ] [ drop ] }
@@ -383,13 +384,26 @@ M: windows-ui-backend (close-window)
         RegisterClassEx dup win32-error=0/f
     ] when ;
 
-: create-window ( width height -- hwnd )
+: adjust-RECT ( RECT -- )
+    style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
+
+: make-RECT ( world -- RECT )
+    dup world-loc { 40 40 } vmax dup rot rect-dim v+
+    "RECT" <c-object>
+    over first over set-RECT-right
+    swap second over set-RECT-bottom
+    over first over set-RECT-left
+    swap second over set-RECT-top ;
+
+: make-adjusted-RECT ( rect -- RECT )
+    make-RECT dup adjust-RECT ;
+
+: create-window ( rect -- hwnd )
     make-adjusted-RECT
     >r class-name-ptr get-global f r>
     >r >r >r ex-style r> r>
         { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
-        CW_USEDEFAULT dup r>
+    r> get-RECT-dimensions
-    get-RECT-dimensions
     f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
 
 : show-window ( hWnd -- )
@@ -424,7 +438,7 @@ M: windows-ui-backend (close-window)
     get-dc dup setup-pixel-format dup get-rc ;
 
 M: windows-ui-backend (open-window) ( world -- )
-    [ rect-dim first2 create-window dup setup-gl ] keep
+    [ create-window dup setup-gl ] keep
     [ f <win> ] keep
     [ swap win-hWnd register-window ] 2keep
     dupd set-world-handle
@@ -445,8 +459,8 @@ M: windows-ui-backend raise-window* ( world -- )
 M: windows-ui-backend set-title ( string world -- )
     world-handle [ nip win-hWnd WM_SETTEXT 0 ] 2keep
     dup win-title [ free ] when*
-    >r malloc-u16-string r>
+    >r malloc-u16-string dup r>
-    dupd set-win-title alien-address
+    set-win-title alien-address
     SendMessage drop ;
 
 M: windows-ui-backend ui

extra/ui/x11/x11.factor

@@ -178,7 +178,7 @@ M: world client-event
         next-event dup
         None XFilterEvent zero? [ drop wait-event ] unless
     ] [
-        ui-step 10 sleep wait-event
+        ui-step ui-wait wait-event
     ] if ;
 
 : do-events ( -- )

extra/webapps/cgi/cgi.factor

@@ -31,13 +31,13 @@ SYMBOL: cgi-root
 
         "method" get >upper "REQUEST_METHOD" set
         "raw-query" get "QUERY_STRING" set
-        "Cookie" header-param "HTTP_COOKIE" set 
+        "cookie" header-param "HTTP_COOKIE" set 
 
-        "User-Agent" header-param "HTTP_USER_AGENT" set
+        "user-agent" header-param "HTTP_USER_AGENT" set
-        "Accept" header-param "HTTP_ACCEPT" set
+        "accept" header-param "HTTP_ACCEPT" set
 
         post? [
-            "Content-Type" header-param "CONTENT_TYPE" set
+            "content-type" header-param "CONTENT_TYPE" set
             "raw-response" get length number>string "CONTENT_LENGTH" set
         ] when
     ] H{ } make-assoc ;

extra/webapps/file/file.factor

@@ -25,7 +25,7 @@ SYMBOL: doc-root
 
 : last-modified-matches? ( filename -- bool )
     file-http-date dup [
-        "If-Modified-Since" header-param = 
+        "if-modified-since" header-param = 
     ] when ;
 
 : not-modified-response ( -- )

extra/webapps/fjsc/fjsc.factor

@@ -25,7 +25,7 @@ IN: webapps.fjsc
 : compile-url ( url -- )
   #! Compile the factor code at the given url, return the javascript.
   dup "http:" head? [ "Unable to access remote sites." throw ] when
-  "http://" "Host" header-param rot 3append http-get compile "();" write flush ;
+  "http://" "host" header-param rot 3append http-get compile "();" write flush ;
 
 \ compile-url {
   { "url" v-required }