Merge branch 'master' of git://factorcode.org/git/factor

extra/builder/builder.factor

@@ -11,6 +11,26 @@ IN: builder
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+SYMBOL: builds-dir
+
+: builds ( -- path )
+  builds-dir get
+  home "/builds" append
+  or ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: prepare-build-machine ( -- )
+  builds make-directory
+  builds cd
+  { "git" "clone" "git://factorcode.org/git/factor.git" } run-process drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : git-clone ( -- desc ) { "git" "clone" "../factor" } ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -19,7 +39,7 @@ VAR: stamp
 
 : enter-build-dir ( -- )
   datestamp >stamp
-  "/builds" cd
+  builds cd
   stamp> make-directory
   stamp> cd ;
 
@@ -69,14 +89,22 @@ VAR: stamp
   
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+SYMBOL: build-status
+
 : (build) ( -- )
 
+  builds-check  
+
+  build-status off
+
   enter-build-dir
 
   "report" [
 
     "Build machine:   " write host-name print
-    "Build directory: " write cwd       print
+    "CPU:             " write cpu       print
+    "OS:              " write os        print
+    "Build directory: " write cwd       print nl
 
     git-clone [ "git clone failed" print ] run-or-bail
 
@@ -88,7 +116,7 @@ VAR: stamp
 
     make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail
 
-    [ my-arch download-image ] [ "Image download error" print throw ] recover
+    [ retrieve-image ] [ "Image download error" print throw ] recover
 
     bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
 
@@ -98,7 +126,7 @@ VAR: stamp
 
     "Boot time: " write "../boot-time" eval-file milli-seconds>time print
     "Load time: " write "../load-time" eval-file milli-seconds>time print
-    "Test time: " write "../test-time" eval-file milli-seconds>time print
+    "Test time: " write "../test-time" eval-file milli-seconds>time print nl
 
     "Did not pass load-everything: " print "../load-everything-vocabs" cat
     "Did not pass test-all: "        print "../test-all-vocabs"        cat
@@ -106,23 +134,32 @@ VAR: stamp
     "Benchmarks: " print
     "../benchmarks" [ stdio get contents eval ] with-file-in benchmarks.
 
-  ] with-file-out ;
+  ] with-file-out
+
+  build-status on ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+SYMBOL: builder-from
+
 SYMBOL: builder-recipients
 
 : tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ;
 
-: build ( -- )
+: subject ( -- str ) build-status get [ "report" ] [ "error" ] if tag-subject ;
-  [ (build) ] [ drop ] recover
+
+: send-builder-email ( -- )
   <email>
-    "ed@factorcode.org"     >>from
+    builder-from get        >>from
     builder-recipients get  >>to
-    "report" tag-subject    >>subject
+    subject                 >>subject
     "../report" file>string >>body
   send ;
 
+: build ( -- )
+  [ (build) ] [ drop ] recover
+  [ send-builder-email ] [ drop "not sending mail" . ] recover ;
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : git-pull ( -- desc )
@@ -141,8 +178,9 @@ SYMBOL: builder-recipients
   = not ;
 
 : build-loop ( -- )
+  builds-check
   [
-    "/builds/factor" cd
+    builds "/factor" append cd
     updates-available?
       [ build ]
     when

extra/builder/util/util.factor

@@ -69,9 +69,9 @@ TUPLE: process* arguments stdin stdout stderr timeout ;
 : milli-seconds>time ( n -- string )
   1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
 
-: eval-file ( file -- obj ) <file-reader> contents eval ;
+: eval-file ( file -- obj ) file-contents eval ;
 
-: cat ( file -- ) <file-reader> contents print ;
+: cat ( file -- ) file-contents print ;
 
 : run-or-bail ( desc quot -- )
   [ [ try-process ] curry   ]
@@ -81,3 +81,6 @@ TUPLE: process* arguments stdin stdout stderr timeout ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+USING: bootstrap.image bootstrap.image.download io.streams.null ;
+
+: retrieve-image ( -- ) [ my-arch download-image ] with-null-stream ;

extra/db/db.factor

@@ -1,7 +1,7 @@
 ! 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 ;
+namespaces sequences sequences.lib tuples words strings ;
 IN: db
 
 TUPLE: db handle insert-statements update-statements delete-statements select-statements ;
@@ -36,13 +36,17 @@ HOOK: <prepared-statement> db ( str -- statement )
 GENERIC: prepare-statement ( statement -- )
 GENERIC: bind-statement* ( obj statement -- )
 GENERIC: reset-statement ( statement -- )
-GENERIC: execute-statement* ( statement -- result-set )
+GENERIC: insert-statement ( statement -- id )
-HOOK: last-id db ( res -- id )
-: execute-statement ( statement -- )
-    execute-statement* dispose ;
 
-: execute-statement-last-id ( statement -- id )
+TUPLE: result-set sql params handle n max ;
-    execute-statement* [ last-id ] with-disposal ;
+GENERIC: query-results ( query -- result-set )
+GENERIC: #rows ( result-set -- n )
+GENERIC: #columns ( result-set -- n )
+GENERIC# row-column 1 ( result-set n -- obj )
+GENERIC: advance-row ( result-set -- )
+GENERIC: more-rows? ( result-set -- ? )
+
+: execute-statement ( statement -- ) query-results dispose ;
 
 : bind-statement ( obj statement -- )
     dup statement-bound? [ dup reset-statement ] when
@@ -50,17 +54,9 @@ HOOK: last-id db ( res -- id )
     [ set-statement-params ] keep
     t swap set-statement-bound? ;
 
-TUPLE: result-set sql params handle n max ;
-
-GENERIC: query-results ( query -- result-set )
-GENERIC: #rows ( result-set -- n )
-GENERIC: #columns ( result-set -- n )
-GENERIC# row-column 1 ( result-set n -- obj )
-GENERIC: advance-row ( result-set -- ? )
-
 : init-result-set ( result-set -- )
     dup #rows over set-result-set-max
-    -1 swap set-result-set-n ;
+    0 swap set-result-set-n ;
 
 : <result-set> ( query handle tuple -- result-set )
     >r >r { statement-sql statement-params } get-slots r>
@@ -74,10 +70,10 @@ GENERIC: advance-row ( result-set -- ? )
     dup #columns [ row-column ] with map ;
 
 : query-each ( statement quot -- )
-    over advance-row [
+    over more-rows? [
-        2drop
+        [ call ] 2keep over advance-row query-each
     ] [
-        [ call ] 2keep query-each
+        2drop
     ] if ; inline
 
 : query-map ( statement quot -- seq )
@@ -98,11 +94,6 @@ GENERIC: advance-row ( result-set -- ? )
 : do-bound-command ( obj query -- )
     [ bind-statement ] keep execute-statement ;
 
-: sql-query ( sql -- rows )
-    <simple-statement> [ do-query ] with-disposal ;
-
-: sql-command ( sql -- )
-    <simple-statement> [ execute-statement ] with-disposal ;
 
 SYMBOL: in-transaction
 HOOK: begin-transaction db ( -- )
@@ -116,3 +107,13 @@ HOOK: rollback-transaction db ( -- )
         begin-transaction
         [ ] [ rollback-transaction ] cleanup commit-transaction
     ] with-variable ;
+
+: sql-query ( sql -- rows )
+    <simple-statement> [ do-query ] with-disposal ;
+
+: sql-command ( sql -- )
+    dup string? [
+        <simple-statement> [ execute-statement ] with-disposal
+    ] [
+        [ [ sql-command ] each ] with-transaction
+    ] if ;

extra/db/postgresql/lib/lib.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! 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 ;
+quotations sequences db.postgresql.ffi alien alien.c-types
+db.types ;
 IN: db.postgresql.lib
 
 : postgresql-result-error-message ( res -- str/f )
@@ -37,13 +38,9 @@ IN: db.postgresql.lib
     >r db get db-handle r>
     [ statement-sql ] keep
     [ statement-params length f ] keep
-    statement-params [ second malloc-char-string ] map >c-void*-array
+    statement-params
+    [ first 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
     ] unless ;
-
-: pq-oid-value ( res -- n )
-    PQoidValue dup InvalidOid = [
-        "postgresql returned an InvalidOid" throw
-    ] when ;

extra/db/postgresql/postgresql-tests.factor

@@ -2,7 +2,7 @@
 ! Set username and password in  the 'connect' word.
 
 USING: kernel db.postgresql alien continuations io prettyprint
-sequences namespaces tools.test db ;
+sequences namespaces tools.test db db.types ;
 IN: temporary
 
 IN: scratchpad
@@ -40,13 +40,13 @@ IN: temporary
     test-db [
         "select * from person where name = $1 and country = $2"
         <simple-statement> [
-            { "Jane" "New Zealand" }
+            { { "Jane" TEXT } { "New Zealand" TEXT } }
             over do-bound-query
 
             { { "Jane" "New Zealand" } } =
             [ "test fails" throw ] unless
 
-            { "John" "America" }
+            { { "John" TEXT } { "America" TEXT } }
             swap do-bound-query
         ] with-disposal
     ] with-db

extra/db/postgresql/postgresql.factor

@@ -3,7 +3,7 @@
 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 ;
+db.tuples db.types tools.annotations math.ranges ;
 IN: db.postgresql
 
 TUPLE: postgresql-db host port pgopts pgtty db user pass ;
@@ -52,11 +52,11 @@ 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-statement execute-statement* ( statement -- obj )
+M: postgresql-result-set row-column ( result-set n -- obj )
-    query-results ;
+    >r dup result-set-handle swap result-set-n r> PQgetvalue ;
 
-: increment-n ( result-set -- n )
+M: postgresql-statement insert-statement ( statement -- id )
-    dup result-set-n 1+ dup rot set-result-set-n ;
+    query-results [ break 0 row-column ] with-disposal ;
 
 M: postgresql-statement query-results ( query -- result-set )
     dup statement-params [
@@ -68,8 +68,11 @@ M: postgresql-statement query-results ( query -- result-set )
     postgresql-result-set <result-set>
     dup init-result-set ;
 
-M: postgresql-result-set advance-row ( result-set -- ? )
+M: postgresql-result-set advance-row ( result-set -- )
-    dup increment-n swap result-set-max >= ;
+    dup result-set-n 1+ swap set-result-set-n ;
+
+M: postgresql-result-set more-rows? ( result-set -- ? )
+    dup result-set-n swap result-set-max < ;
 
 M: postgresql-statement dispose ( query -- )
     dup statement-handle PQclear
@@ -105,36 +108,105 @@ M: postgresql-db commit-transaction ( -- )
 M: postgresql-db rollback-transaction ( -- )
     "ROLLBACK" sql-command ;
 
+: postgresql-type-hash* ( -- assoc )
+    H{
+        { SERIAL "serial" }
+    } ;
 
-M: postgresql-db create-sql ( columns table -- sql )
+: postgresql-type-hash ( -- assoc )
+    H{
+        { INTEGER "integer" }
+        { SERIAL "integer" }
+        { TEXT "text" }
+        { VARCHAR "varchar" }
+        { DOUBLE "real" }
+    } ;
+
+: enquote ( str -- newstr ) "(" swap ")" 3append ;
+
+: 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 )
     [
-        "create table " % %
+        >r remove-id r>
-        " (" % [ ", " % ] [
+        "create function add_" % dup %
-            dup second % " " %
+        "(" %
-            dup third >sql-type % " " %
+        over [ "," % ]
-            sql-modifiers " " join %
+        [ third dup array? [ first ] when >sql-type % ] interleave
-        ] interleave ")" %
+        ")" %
-    ] "" make ;
+        " returns bigint as '" %
 
-M: postgresql-db drop-sql ( table -- sql )
+        2dup "insert into " %
-    [
-        "drop table " % %
-    ] "" make ;
-
-SYMBOL: postgresql-counter
-
-M: postgresql-db insert-sql* ( columns table -- sql )
-    [
-        postgresql-counter off
-        "insert into " %
         %
         "(" %
         dup [ ", " % ] [ second % ] interleave
         ") " %
         " values (" %
-        [ ", " % ] [
+        length [1,b] [ ", " % ] [ "$" % # ] interleave
-            drop "$" % postgresql-counter [ inc ] keep get #
+        "); " %
-        ] 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 -- sql )
+    [
+        "select add_" % %
+        "(" %
+        length [1,b] [ ", " % ] [ "$" % # ] interleave
         ")" %
     ] "" make ;
 
@@ -144,9 +216,10 @@ M: postgresql-db update-sql* ( columns table -- sql )
         %
         " set " %
         dup remove-id
-        [ ", " % ] [ second dup % " = :" % % ] interleave
+        dup length [1,b] swap 2array flip
+        [ ", " % ] [ first2 second % " = $" % # ] interleave
         " where " %
-        [ primary-key? ] find nip second dup % " = :" % %
+        [ primary-key? ] find nip second dup % " = $" % length 2 + #
     ] "" make ;
 
 M: postgresql-db delete-sql* ( columns table -- sql )
@@ -154,23 +227,19 @@ M: postgresql-db delete-sql* ( columns table -- sql )
         "delete from " %
         %
         " where " %
-        first second dup % " = :" % %
+        first second % " = $1" %
     ] "" make ;
 
 M: postgresql-db select-sql* ( columns table -- sql )
     drop ;
 
 M: postgresql-db tuple>params ( columns tuple -- obj )
-    [
+    [ >r dup third swap first r> get-slot-named swap ]
-        >r dup first r> get-slot-named swap third
+    curry { } map>assoc ;
-    ] curry { } map>assoc ;
-    
-M: postgresql-db last-id ( res -- id )
-    pq-oid-value ;
     
 : postgresql-db-modifiers ( -- hashtable )
     H{
-        { +native-id+ "primary key" }
+        { +native-id+ "not null primary key" }
         { +assigned-id+ "primary key" }
         { +autoincrement+ "autoincrement" }
         { +unique+ "unique" }
@@ -189,18 +258,3 @@ M: postgresql-db sql-modifiers* ( modifiers -- str )
             swap at
         ] if
     ] with map [ ] subset ;
-
-: postgresql-type-hash ( -- assoc )
-    H{
-        { INTEGER "integer" }
-        { TEXT "text" }
-        { VARCHAR "text" }
-        { DOUBLE "real" }
-    } ;
-
-M: postgresql-db >sql-type ( obj -- str )
-    dup pair? [
-        first >sql-type
-    ] [
-        postgresql-type-hash at* [ T{ no-sql-type } throw ] unless
-    ] if ;

extra/db/sqlite/lib/lib.factor

@@ -74,10 +74,11 @@ IN: db.sqlite.lib
     dup array? [ first ] when
     {
         { INTEGER [ sqlite-bind-int-by-name ] }
-        { BIG_INTEGER [ sqlite-bind-int-by-name ] }
+        { BIG_INTEGER [ sqlite-bind-int64-by-name ] }
         { TEXT [ sqlite-bind-text-by-name ] }
         { VARCHAR [ sqlite-bind-text-by-name ] }
         { DOUBLE [ sqlite-bind-double-by-name ] }
+        { SERIAL [ sqlite-bind-int-by-name ] }
         ! { NULL [ sqlite-bind-null-by-name ] }
         [ no-sql-type ]
     } case ;
@@ -99,13 +100,13 @@ IN: db.sqlite.lib
 : sqlite-row ( handle -- seq )
     dup sqlite-#columns [ sqlite-column ] with map ;
 
-: step-complete? ( step-result -- bool )
+: sqlite-step-has-more-rows? ( step-result -- bool )
     dup SQLITE_ROW =  [
-        drop f
+        drop t
     ] [
         dup SQLITE_DONE =
-        [ drop ] [ sqlite-check-result ] if t
+        [ drop ] [ sqlite-check-result ] if f
     ] if ;
 
 : sqlite-next ( prepared -- ? )
-    sqlite3_step step-complete? ;
+    sqlite3_step sqlite-step-has-more-rows? ;

extra/db/sqlite/sqlite.factor

@@ -25,9 +25,7 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
 TUPLE: sqlite-statement ;
 C: <sqlite-statement> sqlite-statement
 
-TUPLE: sqlite-result-set advanced? ;
+TUPLE: sqlite-result-set has-more? ;
-: <sqlite-result-set> ( query -- sqlite-result-set )
-    dup statement-handle sqlite-result-set <result-set> ;
 
 M: sqlite-db <simple-statement> ( str -- obj )
     <prepared-statement> ;
@@ -40,13 +38,7 @@ M: sqlite-db <prepared-statement> ( str -- obj )
 M: sqlite-statement dispose ( statement -- )
     statement-handle sqlite-finalize ;
 
-: maybe-advance-row ( result-set -- result-set )
-    dup sqlite-result-set-advanced? [
-        dup advance-row drop
-    ] unless ;
-
 M: sqlite-result-set dispose ( result-set -- )
-    maybe-advance-row
     f swap set-result-set-handle ;
 
 : sqlite-bind ( triples handle -- )
@@ -58,8 +50,12 @@ M: sqlite-statement bind-statement* ( triples statement -- )
 M: sqlite-statement reset-statement ( statement -- )
     statement-handle sqlite-reset ;
 
-M: sqlite-statement execute-statement* ( statement -- obj )
+: last-insert-id ( -- id )
-    query-results ;
+    db get db-handle sqlite3_last_insert_rowid
+    dup zero? [ "last-id failed" throw ] when ;
+
+M: sqlite-statement insert-statement ( statement -- id )
+    execute-statement last-insert-id ;
 
 M: sqlite-result-set #columns ( result-set -- n )
     result-set-handle sqlite-#columns ;
@@ -67,12 +63,16 @@ 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 advance-row ( result-set -- handle ? )
+M: sqlite-result-set advance-row ( result-set -- )
     [ result-set-handle sqlite-next ] keep
-    t swap set-sqlite-result-set-advanced? ;
+    set-sqlite-result-set-has-more? ;
+
+M: sqlite-result-set more-rows? ( result-set -- ? )
+    sqlite-result-set-has-more? ;
 
 M: sqlite-statement query-results ( query -- result-set )
-    dup statement-handle sqlite-result-set <result-set> ;
+    dup statement-handle sqlite-result-set <result-set>
+    dup advance-row ;
 
 M: sqlite-db begin-transaction ( -- )
     "BEGIN" sql-command ;
@@ -93,9 +93,10 @@ M: sqlite-db create-sql ( columns table -- sql )
         ] interleave ")" %
     ] "" make ;
 
-M: sqlite-db drop-sql ( table -- sql )
+M: sqlite-db drop-sql ( columns table -- sql )
     [
         "drop table " % %
+        drop
     ] "" make ;
 
 M: sqlite-db insert-sql* ( columns table -- sql )
@@ -145,11 +146,6 @@ M: sqlite-db tuple>params ( columns tuple -- obj )
         third 3array
     ] curry map ;
 
-M: sqlite-db last-id ( result-set -- id )
-    maybe-advance-row drop
-    db get db-handle sqlite3_last_insert_rowid
-    dup zero? [ "last-id failed" throw ] when ;
-
 : sqlite-db-modifiers ( -- hashtable )
     H{
         { +native-id+ "primary key" }
@@ -175,6 +171,7 @@ M: sqlite-db sql-modifiers* ( modifiers -- str )
 : sqlite-type-hash ( -- assoc )
     H{
         { INTEGER "integer" }
+        { SERIAL "integer" }
         { TEXT "text" }
         { VARCHAR "text" }
         { DOUBLE "real" }
@@ -190,4 +187,3 @@ M: sqlite-db >sql-type ( obj -- str )
 ! HOOK: get-column-value ( n result-set type -- )
 ! M: sqlite get-column-value { { "TEXT" get-text-column } { 
 ! "INTEGER" get-integer-column } ... } case ;
-

extra/db/tuples/tuples-tests.factor

@@ -1,8 +1,8 @@
 ! 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
-db.types continuations namespaces db.postgresql math
+db.types continuations namespaces db.postgresql math ;
-tools.time ;
+! tools.time ;
 IN: temporary
 
 TUPLE: person the-id the-name the-number real ;
@@ -30,7 +30,8 @@ SYMBOL: the-person
 
     [ ] [ the-person get update-tuple ] unit-test
 
-    [ ] [ the-person get delete-tuple ] unit-test ;
+    [ ] [ the-person get delete-tuple ] unit-test
+    [ ] [ person drop-table ] unit-test ;
 
 : test-sqlite ( -- )
     "tuples-test.db" resource-path <sqlite-db> [
@@ -44,7 +45,7 @@ SYMBOL: the-person
 
 person "PERSON"
 {
-    { "the-id" "ROWID" INTEGER +native-id+ }
+    { "the-id" "ID" SERIAL +native-id+ }
     { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
     { "the-number" "AGE" INTEGER { +default+ 0 } }
     { "real" "REAL" DOUBLE { +default+ 0.3 } }
@@ -52,12 +53,12 @@ person "PERSON"
 
 "billy" 10 3.14 <person> the-person set
 
-test-sqlite
+! test-sqlite
-! test-postgresql
+test-postgresql
 
 person "PERSON"
 {
-    { "the-id" "ROWID" INTEGER +assigned-id+ }
+    { "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 } }
@@ -65,5 +66,5 @@ person "PERSON"
 
 1 "billy" 20 6.28 <assigned-person> the-person set
 
-test-sqlite
+! test-sqlite
 ! test-postgresql

extra/db/tuples/tuples.factor

@@ -38,8 +38,9 @@ TUPLE: no-slot-named ;
     [ db-table dupd ] swap
     [ <prepared-statement> ] 3compose cache nip ; inline
 
-HOOK: create-sql db ( columns table -- sql )
+HOOK: create-sql db ( columns table -- seq )
-HOOK: drop-sql db ( table -- sql )
+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 )
@@ -75,12 +76,12 @@ HOOK: tuple>params db ( columns tuple -- obj )
     dup db-columns swap db-table create-sql sql-command ;
     
 : drop-table ( class -- )
-    db-table drop-sql sql-command ;
+    dup db-columns swap db-table drop-sql sql-command ;
 
 : insert-tuple ( tuple -- )
     [
         [ maybe-remove-id ] [ insert-sql ]
-        make-tuple-statement execute-statement-last-id
+        make-tuple-statement insert-statement
     ] keep set-primary-key ;
 
 : update-tuple ( tuple -- )

extra/db/types/types.factor

@@ -11,6 +11,12 @@ SYMBOL: +assigned-id+
 : primary-key? ( spec -- ? )
     [ { +native-id+ +assigned-id+ } member? ] contains? ;
 
+: contains-id? ( columns id -- ? )
+    swap [ member? ] with contains? ;
+    
+: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ;
+: native-id? ( columns -- ? ) +native-id+ contains-id? ;
+
 ! Same concept, SQLite has autoincrement, PostgreSQL has serial
 SYMBOL: +autoincrement+
 SYMBOL: +serial+
@@ -22,6 +28,7 @@ SYMBOL: +not-null+
 
 SYMBOL: +has-many+
 
+SYMBOL: SERIAL
 SYMBOL: INTEGER
 SYMBOL: DOUBLE
 SYMBOL: BOOLEAN