Merge branch 'master' into new_ui

basis/db/tester/tester.factor

@@ -46,12 +46,17 @@ test-2 "TEST2" {
 
 : db-tester2 ( test-db -- )
     [
-        [ test-1 recreate-table ] with-db
-    ] [
         [
-            2 [
-                    10 random 100 random 100 random 100 random test-1 boa
-                    insert-tuple yield
-            ] parallel-each
+            test-1 ensure-table
+            test-2 ensure-table
         ] with-db
+    ] [
+        <db-pool> [
+            10 [
+                10 [
+                    f 100 random 100 random 100 random test-1 boa
+                    insert-tuple yield
+                ] times
+            ] parallel-each
+        ] with-pooled-db
     ] bi ;

basis/http/http.factor

@@ -45,8 +45,8 @@ IN: http
 
 : check-header-string ( str -- str )
     #! http://en.wikipedia.org/wiki/HTTP_Header_Injection
-    dup "\r\n\"" intersect empty?
-    [ "Header injection attack" throw ] unless ;
+    dup "\r\n\"" intersects?
+    [ "Header injection attack" throw ] when ;
 
 : write-header ( assoc -- )
     >alist sort-keys [
@@ -97,8 +97,8 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
     ] { } make ;
 
 : check-cookie-string ( string -- string' )
-    dup "=;'\"\r\n" intersect empty?
-    [ "Bad cookie name or value" throw ] unless ;
+    dup "=;'\"\r\n" intersects?
+    [ "Bad cookie name or value" throw ] when ;
 
 : unparse-cookie-value ( key value -- )
     {

basis/regexp/dfa/dfa.factor

@@ -57,7 +57,7 @@ IN: regexp.dfa
     dup
     [ nfa-table>> final-states>> keys ]
     [ dfa-table>> transitions>> states ] bi
-    [ intersect empty? not ] with filter
+    [ intersects? ] with filter
 
     swap dfa-table>> final-states>>
     [ conjoin ] curry each ;

basis/smtp/smtp.factor

@@ -68,8 +68,8 @@ ERROR: bad-email-address email ;
 
 : validate-address ( string -- string' )
     #! Make sure we send funky stuff to the server by accident.
-    dup "\r\n>" intersect empty?
-    [ bad-email-address ] unless ;
+    dup "\r\n>" intersects?
+    [ bad-email-address ] when ;
 
 : mail-from ( fromaddr -- )
     validate-address
@@ -170,8 +170,8 @@ M: plain-auth send-auth
 ERROR: invalid-header-string string ;
 
 : validate-header ( string -- string' )
-    dup "\r\n" intersect empty?
-    [ invalid-header-string ] unless ;
+    dup "\r\n" intersects?
+    [ invalid-header-string ] when ;
 
 : write-header ( key value -- )
     [ validate-header write ]

basis/validators/validators.factor

@@ -69,8 +69,8 @@ IN: validators
 
 : v-one-line ( str -- str )
     v-required
-    dup "\r\n" intersect empty?
-    [ "must be a single line" throw ] unless ;
+    dup "\r\n" intersects?
+    [ "must be a single line" throw ] when ;
 
 : v-one-word ( str -- str )
     v-required

core/sets/sets-docs.factor

@@ -13,6 +13,8 @@ $nl
 { $subsection diff }
 { $subsection intersect }
 { $subsection union }
+"Set-theoretic predicates:"
+{ $subsection intersects? }
 { $subsection subset? }
 { $subsection set= }
 "A word used to implement the above:"
@@ -104,9 +106,15 @@ HELP: union
 
 { diff intersect union } related-words
 
+HELP: intersects?
+{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "seq1" } " and " { $snippet "seq2" } " have any elements in common." }
+{ $notes "If one of the sequences is empty, the result is always " { $link f } "." } ;
+
 HELP: subset?
 { $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
-{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." } ;
+{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." }
+{ $notes "If " { $snippet "seq1" } " is empty, the result is always " { $link t } "." } ;
 
 HELP: set=
 { $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }

core/sets/sets-tests.factor

@@ -21,3 +21,11 @@ IN: sets.tests
 
 [ V{ 1 2 3 } ]
 [ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test
+
+[ t ] [ { 1 2 } { 1 3 } intersects? ] unit-test
+
+[ f ] [ { 4 2 } { 1 3 } intersects? ] unit-test
+
+[ f ] [ { } { 1 } intersects? ] unit-test
+
+[ f ] [ { 1 } { } intersects? ] unit-test

core/sets/sets.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs hashtables kernel sequences vectors ;
 IN: sets
@@ -31,17 +31,26 @@ IN: sets
 : all-unique? ( seq -- ? )
     dup length <hashtable> [ (all-unique?) ] curry all? ;
 
+<PRIVATE
+
+: tester ( seq -- quot ) unique [ key? ] curry ; inline
+
+PRIVATE>
+
 : intersect ( seq1 seq2 -- newseq )
-    unique [ key? ] curry filter ;
+    tester filter ;
+
+: intersects? ( seq1 seq2 -- newseq )
+    tester contains? ;
 
 : diff ( seq1 seq2 -- newseq )
-    unique [ key? not ] curry filter ;
+    tester [ not ] compose filter ;
 
 : union ( seq1 seq2 -- newseq )
     append prune ;
 
 : subset? ( seq1 seq2 -- ? )
-    unique [ key? ] curry all? ;
+    tester all? ;
 
 : set= ( seq1 seq2 -- ? )
     [ unique ] bi@ = ;

core/splitting/splitting.factor

@@ -48,12 +48,12 @@ IN: splitting
 : split ( seq separators -- pieces ) [ split, ] { } make ;
 
 : string-lines ( str -- seq )
-    dup "\r\n" intersect empty? [
-        1array
-    ] [
+    dup "\r\n" intersects? [
         "\n" split [
             but-last-slice [
                 "\r" ?tail drop "\r" split
             ] map
         ] keep peek "\r" split suffix concat
+    ] [
+        1array
     ] if ;