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

basis/db/sqlite/lib/lib.factor

@@ -166,7 +166,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
 : sqlite-row ( handle -- seq )
     dup sqlite-#columns [ sqlite-column ] with map ;
 
-: sqlite-step-has-more-rows? ( prepared -- bool )
+: sqlite-step-has-more-rows? ( prepared -- ? )
     {
         { SQLITE_ROW [ t ] }
         { SQLITE_DONE [ f ] }

basis/sequences/deep/authors.txt

@@ -1 +1,2 @@
 Daniel Ehrenberg
+Doug Coleman

basis/sequences/deep/deep-tests.factor

@@ -24,3 +24,18 @@ IN: sequences.deep.tests
 [ "foo" ] [ "foo" [ string? ] deep-find ] unit-test
 
 [ { { 1 2 } 1 2 } ] [ [ { 1 2 } [ , ] deep-each ] { } make ] unit-test
+
+[ t ]
+[ { { 1 2 3 } 4 } { { { 1 { { 1 2 3 } 4 } } } 2 } deep-member? ] unit-test
+
+[ t ]
+[ { { 1 2 3 } 4 } { { { 1 2 3 } 4 } 2 } deep-member? ] unit-test
+
+[ f ]
+[ { 1 2 3 4 } { 1 2 3 { 4 } } deep-subseq? ] unit-test
+
+[ t ]
+[ { 1 2 3 4 } { 1 2 3 4 } deep-subseq? ] unit-test
+
+[ t ]
+[ { 1 2 3 4 } { { 1 2 3 4 } } deep-subseq? ] unit-test

basis/sequences/deep/deep.factor

@@ -1,6 +1,6 @@
-! Copyright (C) 2007 Daniel Ehrenberg
+! Copyright (C) 2007, 2008 Daniel Ehrenberg, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel strings math ;
+USING: sequences kernel strings math fry ;
 IN: sequences.deep
 
 ! All traversal goes in postorder
@@ -38,6 +38,16 @@ M: object branch? drop f ;
 : deep-all? ( obj quot -- ? )
     [ not ] compose deep-contains? not ; inline
 
+: deep-member? ( obj seq -- ? )
+    swap '[
+        _ swap dup branch? [ member? ] [ 2drop f ] if
+    ] deep-find >boolean ;
+
+: deep-subseq? ( subseq seq -- ? )
+    swap '[
+        _ swap dup branch? [ subseq? ] [ 2drop f ] if
+    ] deep-find >boolean ;
+
 : deep-change-each ( obj quot: ( elt -- elt' ) -- )
     over branch? [
         [ [ call ] keep over [ deep-change-each ] dip ] curry change-each

basis/smtp/smtp.factor

@@ -102,7 +102,7 @@ M: message-contains-dot summary ( obj -- string )
 
 LOG: smtp-response DEBUG
 
-: multiline? ( response -- boolean )
+: multiline? ( response -- ? )
     3 swap ?nth CHAR: - = ;
 
 : (receive-response) ( -- )

basis/ui/windows/windows.factor

@@ -172,10 +172,10 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
         { 27 "ESC" }
     } ;
 
-: exclude-key-wm-keydown? ( n -- bool )
+: exclude-key-wm-keydown? ( n -- ? )
     exclude-keys-wm-keydown key? ;
 
-: exclude-key-wm-char? ( n -- bool )
+: exclude-key-wm-char? ( n -- ? )
     exclude-keys-wm-char key? ;
 
 : keystroke>gesture ( n -- mods sym )

basis/windows/com/wrapper/wrapper.factor

@@ -123,7 +123,7 @@ unless
 
 : (make-callbacks) ( implementations -- sequence )
     dup [ first ] map (make-iunknown-methods)
-    [ >r >r first2 r> r> swap (make-interface-callbacks) ]
+    [ [ first2 ] 2dip swap (make-interface-callbacks) ]
     curry map-index ;
 
 : (malloc-wrapped-object) ( wrapper -- wrapped-object )

basis/windows/time/time.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types kernel math windows windows.kernel32
-namespaces calendar ;
+namespaces calendar math.bitwise ;
 IN: windows.time
 
 : >64bit ( lo hi -- n )
@@ -28,8 +28,8 @@ IN: windows.time
 : windows-time>FILETIME ( n -- FILETIME )
     "FILETIME" <c-object>
     [
-        [ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep
+        [ 32 bits set-FILETIME-dwLowDateTime ] 2keep
-        >r -32 shift r> set-FILETIME-dwHighDateTime
+        [ -32 shift ] dip set-FILETIME-dwHighDateTime
     ] keep ;
 
 : timestamp>FILETIME ( timestamp -- FILETIME/f )

extra/bank/bank.factor

@@ -20,7 +20,7 @@ C: <transaction> transaction
 : balance>> ( account -- balance ) transactions>> total ;
 
 : open-account ( name interest-rate interest-payment-day opening-date opening-balance -- account )
-    >r [ <account> ] keep r> "Account Opened" <transaction> >>transaction ;
+    [ [ <account> ] keep ] dip "Account Opened" <transaction> >>transaction ;
 
 : daily-rate ( yearly-rate day -- daily-rate )
     days-in-year / ;
@@ -56,7 +56,7 @@ C: <transaction> transaction
 
 : each-day ( quot start end -- )
     2dup before? [
-        >r dup >r over >r swap call r> r> 1 days time+ r> each-day
+        [ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day
     ] [
         3drop
     ] if ;

extra/crypto/hmac/hmac.factor

@@ -10,15 +10,15 @@ IN: crypto.hmac
     initialize-sha1 process-sha1-block
     stream>sha1 get-sha1
     initialize-sha1
-    >r process-sha1-block r>
+    [ process-sha1-block ]
-    process-sha1-block get-sha1 ;
+    [ process-sha1-block ] bi* get-sha1 ;
 
 : md5-hmac ( Ko Ki -- hmac )
     initialize-md5 process-md5-block
     stream>md5 get-md5
     initialize-md5
-    >r process-md5-block r>
+    [ process-md5-block ]
-    process-md5-block get-md5 ;
+    [ process-md5-block ] bi* get-md5 ;
 
 : seq-bitxor ( seq seq -- seq )
     [ bitxor ] 2map ;

extra/html/parser/analyzer/analyzer.factor

@@ -130,7 +130,7 @@ TUPLE: link attributes clickable ;
 
 : find-forms ( vector -- vector' )
     "form" over find-opening-tags-by-name
-    swap [ >r first2 r> find-between* ] curry map
+    swap [ [ first2 ] dip find-between* ] curry map
     [ [ name>> { "form" "input" } member? ] filter ] map ;
 
 : find-html-objects ( vector string -- vector' )

extra/namespaces/lib/lib.factor

@@ -6,7 +6,7 @@ IN: namespaces.lib
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: save-namestack ( quot -- ) namestack >r call r> set-namestack ;
+: save-namestack ( quot -- ) namestack slip set-namestack ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/roman/roman.factor

@@ -26,7 +26,7 @@ ERROR: roman-range-error n ;
 
 : (>roman) ( n -- )
     roman-values roman-digits [
-        >r /mod swap r> <repetition> concat %
+        [ /mod swap ] dip <repetition> concat %
     ] 2each drop ;
 
 : (roman>) ( seq -- n )
@@ -56,7 +56,7 @@ PRIVATE>
     [ roman> ] bi@ ;
 
 : binary-roman-op ( str1 str2 quot -- str3 )
-    >r 2roman> r> call >roman ; inline
+    [ 2roman> ] dip call >roman ; inline
 
 PRIVATE>
 
@@ -73,6 +73,6 @@ PRIVATE>
     [ /i ] binary-roman-op ;
 
 : roman/mod ( str1 str2 -- str3 str4 )
-    [ /mod ] binary-roman-op >r >roman r> ;
+    [ /mod ] binary-roman-op [ >roman ] dip ;
 
 : ROMAN: scan roman> parsed ; parsing

extra/slides/lib.factor

@@ -1,52 +0,0 @@
-USING: arrays assocs kernel vectors sequences namespaces
-       random math.parser math fry ;
-
-IN: assocs.lib
-
-: set-assoc-stack ( value key seq -- )
-    dupd [ key? ] with find-last nip set-at ;
-
-: at-default ( key assoc -- value/key )
-    dupd at [ nip ] when* ;
-
-: replace-at ( assoc value key -- assoc )
-    >r >r dup r> 1vector r> rot set-at ;
-
-: peek-at* ( assoc key -- obj ? )
-    swap at* dup [ >r peek r> ] when ;
-
-: peek-at ( assoc key -- obj )
-    peek-at* drop ;
-
-: >multi-assoc ( assoc -- new-assoc )
-    [ 1vector ] assoc-map ;
-
-: multi-assoc-each ( assoc quot -- )
-    [ with each ] curry assoc-each ; inline
-
-: insert ( value variable -- ) namespace push-at ;
-
-: generate-key ( assoc -- str )
-    >r 32 random-bits >hex r>
-    2dup key? [ nip generate-key ] [ drop ] if ;
-
-: set-at-unique ( value assoc -- key )
-    dup generate-key [ swap set-at ] keep ;
-
-: histogram ( assoc quot -- assoc' )
-    H{ } clone [
-        swap [ change-at ] 2curry assoc-each
-    ] keep ; inline
-
-: inc-at ( key assoc -- )
-    [ 0 or 1 + ] change-at ;
-
-: ?at ( obj assoc -- value/obj ? )
-    dupd at* [ [ nip ] [ drop ] if ] keep ;
-
-: if-at ( obj assoc quot1 quot2 -- )
-    [ ?at ] 2dip if ; inline
-
-: when-at ( obj assoc quot -- ) [ ] if-at ; inline
-
-: unless-at ( obj assoc quot -- ) [ ] swap if-at ; inline

extra/state-machine/state-machine.factor

@@ -21,14 +21,14 @@ M: missing-state error.
     ! quot is ( state string -- output-string )
     [ missing-state ] <array> dup
     [
-        [ >r dup [ data>> ] [ place>> ] bi r> ] %
+        [ [ dup [ data>> ] [ place>> ] bi ] dip ] %
         [ swapd bounds-check dispatch ] curry ,
         [ each pick (>>place) swap (>>date) ] %
     ] [ ] make [ over make ] curry ;
 
 : define-machine ( word state-class -- )
     execute make-machine
-    >r over r> define
+    [ over ] dip define
     "state-table" set-word-prop ;
 
 : MACHINE:

extra/taxes/usa/federal/federal.factor

@@ -56,4 +56,4 @@ M: federal withholding* ( salary w4 tax-table entity -- x )
     ] if ;
 
 : net ( salary w4 collector -- x )
-    >r dupd r> total-withholding - ;
+    [ dupd ] dip total-withholding - ;

extra/units/units.factor

@@ -81,7 +81,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
 
 : d= ( d d -- ? ) comparison-op number= ;
 
-: d~ ( d d delta -- ? ) >r comparison-op r> ~ ;
+: d~ ( d d delta -- ? ) [ comparison-op ] dip ~ ;
 
 : d-min ( d d -- d ) [ d< ] most ;