Merge branch 'experimental' into couchdb

basis/db/postgresql/postgresql.factor

@@ -230,6 +230,7 @@ M: postgresql-db persistent-table ( -- hashtable )
 
         { +foreign-id+ { f f "references" } }
 
+        { +on-update+ { f f "on update" } }
         { +on-delete+ { f f "on delete" } }
         { +restrict+ { f f "restrict" } }
         { +cascade+ { f f "cascade" } }

basis/db/queries/queries.factor

@@ -114,6 +114,9 @@ M: sequence where ( spec obj -- )
         [ " or " 0% ] [ dupd where ] interleave drop
     ] in-parens ;
 
+M: NULL where ( spec obj -- )
+    drop column-name>> 0% " is NULL" 0% ;
+
 : object-where ( spec obj -- )
     over column-name>> 0% " = " 0% bind# ;
 

basis/db/sqlite/sqlite.factor

@@ -178,6 +178,7 @@ M: sqlite-db persistent-table ( -- assoc )
         { +random-id+ { "integer" "integer" f } }
         { +foreign-id+ { "integer" "integer" "references" } }
 
+        { +on-update+ { f f "on update" } }
         { +on-delete+ { f f "on delete" } }
         { +restrict+ { f f "restrict" } }
         { +cascade+ { f f "cascade" } }

basis/db/tuples/tuples-docs.factor

@@ -229,7 +229,7 @@ T{ book
 "Now we've created a book. Let's save it to the database."
 { $code <" USING: db db.sqlite fry io.files ;
 : with-book-tutorial ( quot -- )
-     '[ "book-tutorial.db" temp-file sqlite-db _ with-db ] call ;
+     '[ "book-tutorial.db" temp-file <sqlite-db> _ with-db ] call ;
 
 [
     book recreate-table

basis/db/tuples/tuples-tests.factor

@@ -472,7 +472,12 @@ TUPLE: exam id name score ;
         T{ exam } select-tuples
     ] unit-test
 
-    [ 4 ] [ T{ exam } count-tuples ] unit-test ;
+    [ 4 ] [ T{ exam } count-tuples ] unit-test
+
+    [ ] [ T{ exam { score 10 } } insert-tuple ] unit-test
+
+    [ 10 ]
+    [ T{ exam { name NULL } } select-tuples first score>> ] unit-test ;
 
 TUPLE: bignum-test id m n o ;
 : <bignum-test> ( m n o -- obj )

basis/db/types/types.factor

@@ -26,8 +26,8 @@ SINGLETONS: +db-assigned-id+ +user-assigned-id+ +random-id+ ;
 UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
 
 SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
-+foreign-id+ +has-many+ +on-delete+ +restrict+ +cascade+ +set-null+
-+set-default+ ;
++foreign-id+ +has-many+ +on-update+ +on-delete+ +restrict+ +cascade+
++set-null+ +set-default+ ;
 
 SYMBOL: IGNORE
 
@@ -91,7 +91,7 @@ ERROR: not-persistent class ;
 
 : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
 
-SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
+SINGLETONS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
 DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
 FACTOR-BLOB NULL URL ;
 

core/alien/alien-docs.factor

@@ -302,8 +302,8 @@ ARTICLE: "embedding" "Embedding Factor into C applications"
 "The Factor " { $snippet "Makefile" } " builds the Factor VM both as an executable and a library. The library can be used by other applications. File names for the library on various operating systems:"
 { $table
     { "OS" "Library name" "Shared?" }
-    { "Windows XP/Vista" { $snippet "factor-nt.dll" } "Yes" }
-    { "Windows CE" { $snippet "factor-ce.dll" } "Yes" }
+    { "Windows XP/Vista" { $snippet "factor.dll" } "Yes" }
+    ! { "Windows CE" { $snippet "factor-ce.dll" } "Yes" }
     { "Mac OS X" { $snippet "libfactor.dylib" } "Yes" }
     { "Other Unix" { $snippet "libfactor.a" } "No" }
 }

extra/bind-in/bind-in.factor

@@ -0,0 +1,12 @@
+
+USING: kernel parser lexer locals.private ;
+
+IN: bind-in
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ->
+  "[" parse-tokens make-locals dup push-locals
+  \ ] (parse-lambda) <lambda>
+  parsed-lambda
+  \ call parsed ; parsing

extra/dns/cache/nx/nx.factor

@@ -0,0 +1,35 @@
+
+USING: kernel assocs locals combinators
+       math math.functions system unicode.case ;
+
+IN: dns.cache.nx
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: nx-cache ( -- table ) H{ } ;
+
+: nx-cache-at        (      name -- time ) >lower nx-cache at        ;
+: nx-cache-delete-at (      name --      ) >lower nx-cache delete-at ;
+: nx-cache-set-at    ( time name --      ) >lower nx-cache set-at    ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: now ( -- seconds ) millis 1000.0 / round >integer ;
+
+:: non-existent-name? ( NAME -- ? )
+   [let | TIME [ NAME nx-cache-at ] |
+     {
+       { [ TIME f    = ] [                         f ] }
+       { [ TIME now <= ] [ NAME nx-cache-delete-at f ] }
+       { [ t           ] [                         t ] }
+     }
+     cond
+   ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-non-existent-name ( NAME TTL -- )
+   [let | TIME [ TTL now + ] | TIME NAME nx-cache-set-at ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+

extra/dns/cache/rr/rr.factor

@@ -0,0 +1,65 @@
+
+USING: kernel sequences assocs sets locals combinators
+       accessors system math math.functions unicode.case prettyprint
+       combinators.cleave dns ;
+
+IN: dns.cache.rr
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <entry> time data ;
+
+: now ( -- seconds ) millis 1000.0 / round >integer ;
+
+: expired? ( <entry> -- ? ) time>> now <= ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-cache-key ( obj -- key )
+  { [ name>> >lower ] [ type>> unparse ] [ class>> unparse ] } 1arr " " join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cache ( -- table ) H{ } ;
+
+: cache-at     (     obj -- ent ) make-cache-key cache at ;
+: cache-delete (     obj --     ) make-cache-key cache delete-at ;
+: cache-set-at ( ent obj --     ) make-cache-key cache set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-get ( OBJ -- rrs/f )
+   [let | ENT [ OBJ cache-at ] |
+     {
+       { [ ENT f =      ] [                  f ] }
+       { [ ENT expired? ] [ OBJ cache-delete f ] }
+       {
+         [ t ]
+         [
+           [let | NAME  [ OBJ name>>       ]
+                  TYPE  [ OBJ type>>       ]
+                  CLASS [ OBJ class>>      ]
+                  TTL   [ now ENT time>> - ] |
+             ENT data>>
+               [| RDATA | T{ rr f NAME TYPE CLASS TTL RDATA } ]
+             map
+           ]
+         ]
+       }
+     }
+     cond
+   ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-add ( RR -- )
+   [let | ENT   [ RR cache-at    ]
+          TIME  [ RR ttl>> now + ]
+          RDATA [ RR rdata>>     ] |
+     {
+       { [ ENT f =      ] [ T{ <entry> f TIME V{ RDATA } } RR cache-set-at ] }
+       { [ ENT expired? ] [ RR cache-delete RR cache-add                   ] }
+       { [ t            ] [ TIME ENT (>>time) RDATA ENT data>> adjoin      ] }
+     }
+     cond
+   ] ;

extra/hats/authors.txt

@@ -0,0 +1 @@
+Alex Chapman

extra/hats/hats-tests.factor

@@ -0,0 +1,87 @@
+! Copyright (C) 2008 Alex Chapman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: boxes hats kernel namespaces symbols tools.test ;
+IN: hats.tests
+
+SYMBOLS: lion giraffe elephant rabbit ;
+
+! caps
+[ rabbit ] [ rabbit <cap> out ] unit-test
+[ rabbit ] [ f <cap> rabbit in out ] unit-test
+[ rabbit ] [ rabbit <cap> take ] unit-test
+[ f ] [ rabbit <cap> empty-hat out ] unit-test
+[ rabbit f ] [ rabbit <cap> [ take ] keep out ] unit-test
+[ rabbit t ] [ rabbit <cap> [ take ] keep empty-hat? ] unit-test
+[ lion ] [ rabbit <cap> [ drop lion ] change-hat out ] unit-test
+
+! bowlers
+[ giraffe ] [ [ giraffe rabbit set rabbit <bowler> out ] with-scope ] unit-test
+
+[ rabbit ]
+[
+    [
+        lion rabbit set [
+            rabbit rabbit set rabbit <bowler> out
+        ] with-scope
+    ] with-scope
+] unit-test
+
+[ rabbit ] [
+    rabbit <bowler>
+    [
+        lion rabbit set [
+            rabbit rabbit set out
+        ] with-scope
+    ] with-scope
+] unit-test
+
+[ elephant ] [
+    rabbit <bowler>
+    [
+        elephant rabbit set [
+            rabbit rabbit set
+        ] with-scope
+        out
+    ] with-scope
+] unit-test
+
+[ rabbit ] [
+    rabbit <bowler>
+    [
+        elephant in [
+            rabbit in out
+        ] with-scope
+    ] with-scope
+] unit-test
+
+[ elephant ] [
+    rabbit <bowler>
+    [
+        elephant in [
+            rabbit in
+        ] with-scope
+        out
+    ] with-scope
+] unit-test
+
+! Top Hats
+[ lion ] [ lion rabbit set-global rabbit <top-hat> out ] unit-test
+[ giraffe ] [ rabbit <top-hat> giraffe in out ] unit-test
+
+! Tuple hats
+TUPLE: foo bar ;
+C: <foo> foo
+
+: test-tuple ( -- tuple )
+    rabbit <foo> ;
+
+: test-slot-hat ( -- slot-hat )
+    test-tuple 2 <slot-hat> ; ! hack!
+
+[ rabbit ] [ test-slot-hat out ] unit-test
+[ lion ] [ test-slot-hat lion in out ] unit-test
+
+! Boxes as hats
+[ rabbit ] [ <box> rabbit in out ] unit-test
+[ <box> rabbit in lion in ] must-fail
+[ <box> out ] must-fail

extra/hats/hats.factor

@@ -0,0 +1,57 @@
+! Copyright (C) 2008 Alex Chapman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors boxes kernel namespaces ;
+IN: hats
+
+! Bullwinkle: Hey Rocky, watch me pull a rabbit out of my hat!
+! Rocky: But that trick never works!
+! Bullwinkle: This time for sure!
+
+! hat protocol
+MIXIN: hat
+
+GENERIC: out ( hat -- object )
+GENERIC: (in) ( object hat -- )
+
+: in ( hat object -- hat ) over (in) ; inline
+: empty-hat? ( hat -- ? ) out not ; inline
+: empty-hat ( hat -- hat ) f in ; inline
+: take ( hat -- object ) dup out f rot (in) ; inline
+: change-hat ( hat quot -- hat )
+    over >r >r out r> call r> swap in ; inline
+
+! caps (the simplest of hats)
+TUPLE: cap object ;
+C: <cap> cap
+M: cap out ( cap -- object ) object>> ;
+M: cap (in) ( object cap -- ) (>>object) ;
+INSTANCE: cap hat
+
+! bowlers (dynamic variable hats)
+TUPLE: bowler variable ;
+C: <bowler> bowler
+M: bowler out ( bowler -- object ) variable>> get ;
+M: bowler (in) ( object bowler -- ) variable>> set ;
+INSTANCE: bowler hat
+
+! Top Hats (global variable hats)
+TUPLE: top-hat variable ;
+C: <top-hat> top-hat
+M: top-hat out ( top-hat -- object ) variable>> get-global ;
+M: top-hat (in) ( object top-hat -- ) variable>> set-global ;
+INSTANCE: top-hat hat
+
+USE: slots.private
+! Slot hats
+TUPLE: slot-hat tuple slot ;
+C: <slot-hat> slot-hat
+: >slot-hat< ( slot-hat -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline
+M: slot-hat out ( slot-hat -- object ) >slot-hat< slot ;
+M: slot-hat (in) ( object slot-hat -- ) >slot-hat< set-slot ;
+INSTANCE: slot-hat hat
+
+! Put a box on your head
+M: box out ( box -- object ) box> ;
+M: box (in) ( object box -- ) >box ;
+INSTANCE: box hat
+

extra/hats/summary.txt

@@ -0,0 +1 @@
+A protocol for getting and setting

extra/webapps/calculator/calculator.factor

@@ -33,7 +33,7 @@ TUPLE: calculator < dispatcher ;
 ! Deployment example
 USING: db.sqlite furnace.alloy namespaces http.server ;
 
-: calculator-db ( -- params db ) "calculator.db" sqlite-db ;
+: calculator-db ( -- db ) "calculator.db" <sqlite-db> ;
 
 : run-calculator ( -- )
     <calculator>

extra/webapps/counter/counter.factor

@@ -32,7 +32,7 @@ M: counter-app init-session* drop 0 count sset ;
 ! Deployment example
 USING: db.sqlite furnace.alloy namespaces ;
 
-: counter-db ( -- params db ) "counter.db" sqlite-db ;
+: counter-db ( -- db ) "counter.db" <sqlite-db> ;
 
 : run-counter ( -- )
     <counter-app>