Merge branch 'master' of http://factorcode.org/git/factor into semantic-db

Conflicts:

	extra/db/tuples/tuples.factor

diff --cc extra/db/sqlite/sqlite.factor
index 17948bbbc42f54d48002cddebaf18e9218b0be83,b8e8bca300bb05eb514ee6af8293d265b3fd2759..d1a0fe72a14ef518bda5d2c00330f5cc03916c88
--- 1/extra/db/sqlite/sqlite.factor
--- 2/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@@ -1,10 -1,10 +1,10 @@@
  ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
  ! See http://factorcode.org/license.txt for BSD license.
  USING: alien arrays assocs classes compiler db
 -hashtables io.files kernel math math.parser namespaces
 +hashtables io.files io.files.tmp 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 ;
@@@ -22,13 -22,7 +22,12 @@@ M: sqlite-db dispose ( db -- ) dispose-
  : with-sqlite ( path quot -- )
      >r <sqlite-db> r> with-db ; inline
  
 +: with-tmp-sqlite ( quot -- )
 +    ".db" [
 +        swap with-sqlite
 +    ] with-tmpfile ;
 +
  TUPLE: sqlite-statement ;
- C: <sqlite-statement> sqlite-statement
  
  TUPLE: sqlite-result-set has-more? ;
  

diff --cc extra/db/tuples/tuples.factor
index 00f0f97c9e4d78612d10265e019ae29e6c5ccdab,4e8b8ec9d00f0d341e5fed904c31b63b82fd9d72..c775bac3ab9700952d16075fe9fa33be48e99b47
--- 1/extra/db/tuples/tuples.factor
--- 2/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@@ -1,130 -1,100 +1,106 @@@
  ! 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
- math.parser io prettyprint db.types continuations ;
+ tuples words sequences slots math
+ 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 ;
- : db-table ( class -- obj ) "db-table" word-prop ;
- 
- 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 ;
- 
- : offset-of-slot ( str obj -- n )
-     class slot-spec-named dup [ slot-spec-offset ] when ;
- 
- DEFER: get-slot-named
- : get-delegate-slot-named ( str obj -- value )
-     delegate [ get-slot-named ] [ drop no-slot-named ] if* ;
+ : 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 ;
  
- : get-slot-named ( str obj -- value )
-     2dup offset-of-slot [
-         rot drop slot
-     ] [
-         get-delegate-slot-named
-     ] if* ;
+ : db-table ( class -- obj ) "db-table" word-prop ;
+ : db-columns ( class -- obj ) "db-columns" word-prop ;
+ : db-relations ( class -- obj ) "db-relations" word-prop ;
  
- DEFER: set-slot-named
- : set-delegate-slot-named ( value str obj -- )
-     delegate [ set-slot-named ] [ 2drop no-slot-named ] if* ;
+ : set-primary-key ( key tuple -- )
+     [
+         class db-columns find-primary-key sql-spec-slot-name
+     ] keep set-slot-named ;
  
- : set-slot-named ( value str obj -- )
-     2dup offset-of-slot [
-         rot drop set-slot
-     ] [
-         set-delegate-slot-named
-     ] if* ;
++! : primary-key-spec ( class -- spec )
++!     db-columns [ primary-key? ] find nip ;
++!     
++! : primary-key ( tuple -- obj )
++!     dup class primary-key-spec first swap get-slot-named ;
 +
- : primary-key-spec ( class -- spec )
-     db-columns [ primary-key? ] find nip ;
-     
- : primary-key ( tuple -- obj )
-     dup class primary-key-spec first swap get-slot-named ;
+ ! returns a sequence of prepared-statements
+ HOOK: create-sql-statement db ( class -- obj )
+ HOOK: drop-sql-statement db ( class -- obj )
  
- : set-primary-key ( obj tuple -- )
-     [ class primary-key-spec first ] keep
-     set-slot-named ;
+ HOOK: <insert-native-statement> db ( tuple -- obj )
+ HOOK: <insert-assigned-statement> db ( tuple -- obj )
  
- : cache-statement ( columns class assoc quot -- statement )
-     [ db-table dupd ] swap
-     [ <prepared-statement> ] 3compose cache nip ; inline
+ HOOK: <update-tuple-statement> db ( tuple -- obj )
+ HOOK: <update-tuples-statement> db ( tuple -- obj )
  
- HOOK: create-sql db ( columns table -- seq )
- HOOK: drop-sql db ( columns table -- seq )
+ HOOK: <delete-tuple-statement> db ( tuple -- obj )
+ HOOK: <delete-tuples-statement> db ( tuple -- obj )
  
- HOOK: insert-sql* db ( columns table -- sql )
- HOOK: update-sql* db ( columns table -- sql )
- HOOK: delete-sql* db ( columns table -- sql )
- HOOK: select-sql db ( tuple -- statement )
+ HOOK: <select-by-slots-statement> db ( tuple -- tuple )
  
  HOOK: row-column-typed db ( result-set n type -- sql )
- HOOK: sql-type>factor-type db ( obj type -- obj )
- HOOK: tuple>params db ( columns tuple -- obj )
- 
- 
- HOOK: make-slot-names* db ( quot -- seq )
- HOOK: column-slot-name% db ( spec -- )
- HOOK: column-bind-name% db ( spec -- )
- 
- : make-slots-names ( quot -- seq str )
-     [ make-slot-names* ] "" make ; inline
- : slot-name% ( seq -- ) first % ;
- : column-name% ( seq -- ) second % ;
- : column-type% ( seq -- ) third % ;
- 
- : insert-sql ( columns class -- statement )
-     db get db-insert-statements [ insert-sql* ] cache-statement ;
- 
- : update-sql ( columns class -- statement )
-     db get db-update-statements [ update-sql* ] cache-statement ;
- 
- : delete-sql ( columns class -- statement )
-     db get db-delete-statements [ delete-sql* ] cache-statement ;
- 
- 
- : tuple-statement ( columns tuple quot -- statement )
-     >r [ tuple>params ] 2keep class r> call
-     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 ;
+ HOOK: insert-tuple* db ( tuple statement -- )
+ 
+ : 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 ;
+ 
+ : query-tuples ( statement -- seq )
+     [ statement-out-params ] keep query-results [
+         [ sql-row swap resulting-tuple ] with query-map
+     ] with-disposal ;
+  
+ : query-modify-tuple ( tuple statement -- )
+     [ query-results [ sql-row ] with-disposal ] keep
+     statement-out-params rot [
+         >r [ sql-spec-type sql-type>factor-type ] keep
+         sql-spec-slot-name r> set-slot-named
+     ] curry 2each ;
+ 
+ : sql-props ( class -- columns table )
+     dup db-columns swap db-table ;
+ 
+ : create-table ( class -- ) create-sql-statement execute-statement ;
+ : drop-table ( class -- ) drop-sql-statement execute-statement ;
+ 
+ : insert-native ( tuple -- )
+     dup class <insert-native-statement>
+     [ bind-tuple ] 2keep insert-tuple* ;
+ 
+ : insert-assigned ( tuple -- )
+     dup class <insert-assigned-statement>
+     [ bind-tuple ] keep execute-statement ;
  
  : insert-tuple ( tuple -- )
-     [
-         [ maybe-remove-id ] [ insert-sql ]
-         make-tuple-statement insert-statement
-     ] keep set-primary-key ;
+     dup class db-columns find-primary-key assigned-id? [
+         insert-assigned
+     ] [
+         insert-native
+     ] if ;
  
  : update-tuple ( tuple -- )
-     [ ] [ update-sql ] do-tuple-statement ;
+     dup class <update-tuple-statement>
+     [ bind-tuple ] keep execute-statement ;
  
- : delete-tuple ( tuple -- )
-     [ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ;
+ : update-tuples ( seq -- )
+     <update-tuples-statement> execute-statement ;
  
- : select-tuple ( tuple -- )
-     [ select-sql ] keep do-query ;
- 
- : persist ( tuple -- )
-     dup primary-key [ update-tuple ] [ insert-tuple ] if ;
+ : delete-tuple ( tuple -- )
+     dup class <delete-tuple-statement>
+     [ bind-tuple ] keep execute-statement ;
  
- : define-persistent ( class table columns -- )
-     >r dupd "db-table" set-word-prop r>
-     "db-columns" set-word-prop ;
+ : setup-select ( tuple -- statement )
+     dup dup class <select-by-slots-statement>
+     [ bind-tuple ] keep ;
  
- : define-relation ( spec -- )
-     drop ;
+ : select-tuples ( tuple -- tuple ) setup-select query-tuples ;
+ : select-tuple ( tuple -- tuple/f ) select-tuples ?first ;

diff --cc extra/db/types/types.factor
index 7cacbcf8612be8777b06ad9333f8a788143fcc8d,c84b23c50f274794837f3c36014f5cb9c2f2b283..a9b60b41fbf0547dfb87a5ae30c6b10ae6a543ed
--- 1/extra/db/types/types.factor
--- 2/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@@ -65,3 -111,114 +111,136 @@@ TUPLE: no-sql-modifier 
  ! NULL INTEGER REAL TEXT BLOB
  ! PostgreSQL Types:
  ! http://developer.postgresql.org/pgdocs/postgres/datatype.html
 -    tuck offset-of-slot [ no-slot-named ] unless* slot ;
+ 
+ : 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 ;
+ 
++DEFER: get-slot-named
++: get-delegate-slot-named ( str obj -- value )
++    delegate [ get-slot-named ] [ drop no-slot-named ] if* ;
++
++! : get-slot-named ( str obj -- value )
++!     tuck offset-of-slot [ no-slot-named ] unless* slot ;
++
+ : get-slot-named ( str obj -- value )
 -    tuck offset-of-slot [ no-slot-named ] unless* set-slot ;
++    2dup offset-of-slot [
++        rot drop slot
++    ] [
++        get-delegate-slot-named
++    ] if* ;
++
++DEFER: set-slot-named
++: set-delegate-slot-named ( value str obj -- )
++    delegate [ set-slot-named ] [ 2drop no-slot-named ] if* ;
++
++! : set-slot-named ( value str obj -- )
++!     tuck offset-of-slot [ no-slot-named ] unless* set-slot ;
+ 
+ : set-slot-named ( value str obj -- )
++    2dup offset-of-slot [
++        rot drop set-slot
++    ] [
++        set-delegate-slot-named
++    ] if* ;
+ 
+ : 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 ;