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

build-support/factor.sh

@@ -439,7 +439,7 @@ install_build_system_port() {
 }
 
 usage() {
-    echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap|make-target"
+    echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target"
     echo "If you are behind a firewall, invoke as:"
     echo "env GIT_PROTOCOL=http $0 <command>"
 }

extra/db/postgresql/lib/lib.factor

@@ -72,7 +72,7 @@ M: postgresql-result-null summary ( obj -- str )
 : param-values ( statement -- seq seq2 )
     [ bind-params>> ] [ in-params>> ] bi
     [
-        type>> {
+        >r value>> r> type>> {
             { FACTOR-BLOB [
                 dup [ object>bytes malloc-byte-array/length ] [ 0 ] if
             ] }
@@ -150,6 +150,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
     dup array? [ first ] when
     {
         { +native-id+ [ pq-get-number ] }
+        { +random-id+ [ pq-get-number ] }
         { INTEGER [ pq-get-number ] }
         { BIG-INTEGER [ pq-get-number ] }
         { DOUBLE [ pq-get-number ] }

extra/db/postgresql/postgresql.factor

@@ -39,16 +39,16 @@ M: postgresql-db dispose ( db -- )
 M: postgresql-statement bind-statement* ( statement -- )
     drop ;
 
-GENERIC: postgresql-bind-conversion
+GENERIC: postgresql-bind-conversion ( tuple obj -- low-level-binding )
 
-M: sql-spec postgresql-bind-conversion ( tuple spec -- array )
+M: sql-spec postgresql-bind-conversion ( tuple spec -- obj )
-    slot-name>> swap get-slot-named ;
+    slot-name>> swap get-slot-named <low-level-binding> ;
 
-M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- array )
+M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- obj )
-    nip value>> ;
+    nip value>> <low-level-binding> ;
 
-M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- array )
+M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- obj )
-    nip quot>> call ;
+    nip singleton>> eval-generator <low-level-binding> ;
 
 M: postgresql-statement bind-tuple ( tuple statement -- )
     tuck in-params>>
@@ -201,7 +201,16 @@ M: postgresql-db <insert-nonnative-statement> ( class -- statement )
         ")" 0%
 
         " values(" 0%
-        [ ", " 0% ] [ bind% ] interleave
+        [ ", " 0% ] [
+            dup type>> +random-id+ = [
+                [
+                    drop bind-name%
+                    f random-id-generator
+                ] [ type>> ] bi <generator-bind> 1,
+            ] [
+                bind%
+            ] if
+        ] interleave
         ");" 0%
     ] query-make ;
 

extra/db/queries/queries.factor

@@ -6,6 +6,8 @@ math.bitfields.lib namespaces.lib db db.tuples db.types
 math.intervals ;
 IN: db.queries
 
+GENERIC: where ( specs obj -- )
+
 : maybe-make-retryable ( statement -- statement )
     dup in-params>> [ generator-bind? ] contains? [
         make-retryable
@@ -41,10 +43,11 @@ M: db <delete-tuple-statement> ( specs table -- sql )
         dup column-name>> 0% " = " 0% bind%
     ] query-make ;
 
-M: db random-id-quot ( -- quot )
+M: random-id-generator eval-generator ( singleton -- obj )
-    [ 63 [ 2^ random ] keep 1 - set-bit ] ;
+    drop
-
+    system-random-generator get [
-GENERIC: where ( specs obj -- )
+        63 [ 2^ random ] keep 1 - set-bit
+    ] with-random ;
 
 : interval-comparison ( ? str -- str )
     "from" = " >" " <" ? swap [ "= " append ] when ;
@@ -95,4 +98,3 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
         [ slot-name>> swap get-slot-named ] with subset
         dup empty? [ 2drop ] [ where-clause ] if ";" 0%
     ] query-make ;
-

extra/db/sqlite/sqlite.factor

@@ -53,7 +53,7 @@ M: sqlite-result-set dispose ( result-set -- )
 
 M: sqlite-statement low-level-bind ( statement -- )
     [ statement-bind-params ] [ statement-handle ] bi
-    swap [ first3 sqlite-bind-type ] with each ;
+    swap [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
 
 M: sqlite-statement bind-statement* ( statement -- )
     sqlite-maybe-prepare
@@ -62,16 +62,25 @@ M: sqlite-statement bind-statement* ( statement -- )
 
 GENERIC: sqlite-bind-conversion ( tuple obj -- array )
 
+TUPLE: sqlite-low-level-binding < low-level-binding key type ;
+: <sqlite-low-level-binding> ( key value type -- obj )
+    sqlite-low-level-binding new
+        swap >>type
+        swap >>value
+        swap >>key ;
+
 M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
     [ column-name>> ":" prepend ]
     [ slot-name>> rot get-slot-named ]
-    [ type>> ] tri 3array ;
+    [ type>> ] tri <sqlite-low-level-binding> ;
 
 M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
-    nip [ key>> ] [ value>> ] [ type>> ] tri 3array ;
+    nip [ key>> ] [ value>> ] [ type>> ] tri
+    <sqlite-low-level-binding> ;
 
 M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
-    nip [ key>> ] [ quot>> call ] [ type>> ] tri 3array ;
+    nip [ key>> ] [ singleton>> eval-generator ] [ type>> ] tri
+    <sqlite-low-level-binding> ;
 
 M: sqlite-statement bind-tuple ( tuple statement -- )
     [
@@ -129,14 +138,10 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
         ") values(" 0%
         [ ", " 0% ] [
             dup type>> +random-id+ = [
-                dup modifiers>> find-random-generator
                 [
-                    [
+                    column-name>> ":" prepend dup 0%
-                        column-name>> ":" prepend
+                    random-id-generator
-                        dup 0% random-id-quot
+                ] [ type>> ] bi <generator-bind> 1,
-                    ] with-random
-                ] curry
-                [ type>> ] bi <generator-bind> 1,
             ] [
                 bind%
             ] if
@@ -158,9 +163,9 @@ M: sqlite-db bind% ( spec -- )
 
 M: sqlite-db persistent-table ( -- assoc )
     H{
-        { +native-id+ { "integer primary key" "integer primary key" f } }
+        { +native-id+ { "integer primary key" "integer primary key" "primary key" } }
         { +assigned-id+ { f f "primary key" } }
-        { +random-id+ { "integer primary key" "integer primary key" f } }
+        { +random-id+ { "integer primary key" "integer primary key" "primary key" } }
         { INTEGER { "integer" "integer" "primary key" } }
         { BIG-INTEGER { "bigint" "bigint" } }
         { SIGNED-BIG-INTEGER { "bigint" "bigint" } }

extra/db/tuples/tuples-tests.factor

@@ -342,14 +342,14 @@ C: <secret> secret
 [ test-bignum ] test-postgresql
 [ test-serialize ] test-postgresql
 [ test-intervals ] test-postgresql
-! [ test-random-id ] test-postgresql
+[ test-random-id ] test-postgresql
 
 TUPLE: does-not-persist ;
 
-! [
+[
-    ! [ does-not-persist create-sql-statement ]
+    [ does-not-persist create-sql-statement ]
-    ! [ class \ not-persistent = ] must-fail-with
+    [ class \ not-persistent = ] must-fail-with
-! ] test-sqlite
+] test-sqlite
 
 [
     [ does-not-persist create-sql-statement ]

extra/db/tuples/tuples.factor

@@ -26,11 +26,12 @@ ERROR: not-persistent ;
 
 : set-primary-key ( key tuple -- )
     [
-        class db-columns find-primary-key sql-spec-slot-name
+        class db-columns find-primary-key slot-name>>
     ] keep set-slot-named ;
 
 SYMBOL: sql-counter
-: next-sql-counter sql-counter [ inc ] [ get ] bi number>string ;
+: next-sql-counter ( -- str )
+    sql-counter [ inc ] [ get ] bi number>string ;
 
 ! returns a sequence of prepared-statements
 HOOK: create-sql-statement db ( class -- obj )
@@ -49,6 +50,7 @@ HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
 
 HOOK: insert-tuple* db ( tuple statement -- )
 
+GENERIC: eval-generator ( singleton -- obj )
 SINGLETON: retryable
 
 : make-retryable ( obj -- obj' )
@@ -63,18 +65,12 @@ SINGLETON: retryable
     [ bind-params>> ] [ in-params>> ] bi
     [
         dup generator-bind? [
-            quot>> call over set-second
+            singleton>> eval-generator >>value
         ] [
             drop
         ] if
     ] 2map >>bind-params ;
 
-: handle-random-id ( statement -- )
-    dup in-params>> [ type>> +random-id+ = ] find drop >boolean [
-        retryable >>type
-        random-id-quot >>quot
-    ] when drop ;
-
 M: retryable execute-statement* ( statement type -- )
     drop
     [
@@ -84,21 +80,21 @@ M: retryable execute-statement* ( statement type -- )
     ] curry 10 retry drop ;
 
 : resulting-tuple ( row out-params -- tuple )
-    dup first sql-spec-class new [
+    dup first class>> new [
         [
-            >r sql-spec-slot-name r> set-slot-named
+            >r slot-name>> r> set-slot-named
         ] curry 2each
     ] keep ;
 
 : query-tuples ( statement -- seq )
-    [ statement-out-params ] keep query-results [
+    [ out-params>> ] keep query-results [
         [ sql-row-typed swap resulting-tuple ] with query-map
     ] with-disposal ;
  
 : query-modify-tuple ( tuple statement -- )
     [ query-results [ sql-row-typed ] with-disposal ] keep
-    statement-out-params rot [
+    out-params>> rot [
-        >r sql-spec-slot-name r> set-slot-named
+        >r slot-name>> r> set-slot-named
     ] curry 2each ;
 
 : sql-props ( class -- columns table )

extra/db/types/types.factor

@@ -10,15 +10,17 @@ IN: db.types
 HOOK: persistent-table db ( -- hash )
 HOOK: compound db ( str obj -- hash )
 
-HOOK: random-id-quot db ( -- quot )
-
 TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
 
 TUPLE: literal-bind key type value ;
 C: <literal-bind> literal-bind
 
-TUPLE: generator-bind key quot type ;
+TUPLE: generator-bind key singleton type ;
 C: <generator-bind> generator-bind
+SINGLETON: random-id-generator
+
+TUPLE: low-level-binding value ;
+C: <low-level-binding> low-level-binding
 
 SINGLETON: +native-id+
 SINGLETON: +assigned-id+

extra/semantic-db/semantic-db.factor

@@ -76,7 +76,7 @@ arc "arc"
     create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ;
 
 : param ( value key type -- param )
-    swapd 3array ;
+    swapd <sqlite-low-level-binding> ;
 
 : single-int-results ( bindings sql -- array )
     f f <simple-statement> [ do-bound-query ] with-disposal