Get rid of some more >r/r> usages

basis/cocoa/pasteboard/pasteboard.factor

@@ -20,7 +20,7 @@ IN: cocoa.pasteboard
 : set-pasteboard-string ( str pasteboard -- )
     NSStringPboardType <NSString>
     dup 1array pick set-pasteboard-types
-    >r swap <NSString> r> -> setString:forType: drop ;
+    [ swap <NSString> ] dip -> setString:forType: drop ;
 
 : pasteboard-error ( error -- f )
     "Pasteboard does not hold a string" <NSString>

basis/cocoa/subclassing/subclassing.factor

@@ -36,7 +36,7 @@ IN: cocoa.subclassing
     ] map concat ;
 
 : prepare-method ( ret types quot -- type imp )
-    >r [ encode-types ] 2keep r> [
+    [ [ encode-types ] 2keep ] dip [
         "cdecl" swap 4array % \ alien-callback ,
     ] [ ] make define-temp ;
 

basis/cocoa/views/views.factor

@@ -74,7 +74,7 @@ PRIVATE>
     -> autorelease ;
 
 : <GLView> ( class dim -- view )
-    >r -> alloc 0 0 r> first2 <NSRect> <PixelFormat>
+    [ -> alloc 0 0 ] dip first2 <NSRect> <PixelFormat>
     -> initWithFrame:pixelFormat:
     dup 1 -> setPostsBoundsChangedNotifications:
     dup 1 -> setPostsFrameChangedNotifications: ;
@@ -85,10 +85,11 @@ PRIVATE>
     swap NSRect-h >fixnum 2array ;
 
 : mouse-location ( view event -- loc )
-    over >r
+    [
-    -> locationInWindow f -> convertPoint:fromView:
+        -> locationInWindow f -> convertPoint:fromView:
-    dup NSPoint-x swap NSPoint-y
+        [ NSPoint-x ] [ NSPoint-y ] bi
-    r> -> frame NSRect-h swap - 2array ;
+    ] [ drop -> frame NSRect-h ] 2bi
+    swap - 2array ;
 
 USE: opengl.gl
 USE: alien.syntax

basis/compiler/alien/alien.factor

@@ -18,7 +18,7 @@ IN: compiler.alien
     dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
 
 : parameter-align ( n type -- n delta )
-    over >r c-type-stack-align align dup r> - ;
+    [ c-type-stack-align align dup ] [ drop ] 2bi - ;
 
 : parameter-sizes ( types -- total offsets )
     #! Compute stack frame locations.

basis/compiler/codegen/codegen.factor

@@ -277,7 +277,7 @@ M: object reg-class-full?
 
 : spill-param ( reg-class -- n reg-class )
     stack-params get
-    >r reg-size cell align stack-params +@ r>
+    [ reg-size cell align stack-params +@ ] dip
     stack-params ;
 
 : fastcall-param ( reg-class -- n reg-class )
@@ -313,10 +313,10 @@ M: long-long-type flatten-value-type ( type -- types )
     ] { } make ;
 
 : each-parameter ( parameters quot -- )
-    >r [ parameter-sizes nip ] keep r> 2each ; inline
+    [ [ parameter-sizes nip ] keep ] dip 2each ; inline
 
 : reverse-each-parameter ( parameters quot -- )
-    >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
+    [ [ parameter-sizes nip ] keep ] dip 2reverse-each ; inline
 
 : reset-freg-counts ( -- )
     { int-regs float-regs stack-params } [ 0 swap set ] each ;
@@ -329,15 +329,13 @@ M: long-long-type flatten-value-type ( type -- types )
     #! Moves values from C stack to registers (if word is
     #! %load-param-reg) and registers to C stack (if word is
     #! %save-param-reg).
-    >r
+    [ alien-parameters flatten-value-types ]
-    alien-parameters
+    [ '[ alloc-parameter _ execute ] ]
-    flatten-value-types
+    bi* each-parameter ; inline
-    r> '[ alloc-parameter _ execute ] each-parameter ;
-    inline
 
 : unbox-parameters ( offset node -- )
     parameters>> [
-        %prepare-unbox >r over + r> unbox-parameter
+        %prepare-unbox [ over + ] dip unbox-parameter
     ] reverse-each-parameter drop ;
 
 : prepare-box-struct ( node -- offset )

basis/compiler/codegen/fixup/fixup.factor

@@ -46,28 +46,27 @@ M: integer fixup* , ;
 : indq ( elt seq -- n ) [ eq? ] with find drop ;
 
 : adjoin* ( obj table -- n )
-    2dup indq [ 2nip ] [ dup length >r push r> ] if* ;
+    2dup indq [ 2nip ] [ dup length [ push ] dip ] if* ;
 
 SYMBOL: literal-table
 
 : add-literal ( obj -- n ) literal-table get adjoin* ;
 
 : add-dlsym-literals ( symbol dll -- )
-    >r string>symbol r> 2array literal-table get push-all ;
+    [ string>symbol ] dip 2array literal-table get push-all ;
 
 : rel-dlsym ( name dll class -- )
-    >r literal-table get length >r
+    [ literal-table get length [ add-dlsym-literals ] dip ] dip
-    add-dlsym-literals
+    rt-dlsym rel-fixup ;
-    r> r> rt-dlsym rel-fixup ;
 
 : rel-word ( word class -- )
-    >r add-literal r> rt-xt rel-fixup ;
+    [ add-literal ] dip rt-xt rel-fixup ;
 
 : rel-primitive ( word class -- )
-    >r def>> first r> rt-primitive rel-fixup ;
+    [ def>> first ] dip rt-primitive rel-fixup ;
 
 : rel-immediate ( literal class -- )
-    >r add-literal r> rt-immediate rel-fixup ;
+    [ add-literal ] dip rt-immediate rel-fixup ;
 
 : rel-this ( class -- )
     0 swap rt-label rel-fixup ;

basis/concurrency/conditions/conditions.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: deques threads kernel arrays sequences alarms ;
+USING: deques threads kernel arrays sequences alarms fry ;
 IN: concurrency.conditions
 
 : notify-1 ( deque -- )
@@ -12,15 +12,18 @@ IN: concurrency.conditions
 : queue-timeout ( queue timeout -- alarm )
     #! Add an alarm which removes the current thread from the
     #! queue, and resumes it, passing it a value of t.
-    >r [ self swap push-front* ] keep [
+    [
-        [ delete-node ] [ drop node-value ] 2bi
+        [ self swap push-front* ] keep '[
-        t swap resume-with
+            _ _
-    ] 2curry r> later ;
+            [ delete-node ] [ drop node-value ] 2bi
+            t swap resume-with
+        ]
+    ] dip later ;
 
 : wait ( queue timeout status -- )
     over [
-        >r queue-timeout [ drop ] r> suspend
+        [ queue-timeout [ drop ] ] dip suspend
         [ "Timeout" throw ] [ cancel-alarm ] if
     ] [
-        >r drop [ push-front ] curry r> suspend drop
+        [ drop '[ _ push-front ] ] dip suspend drop
     ] if ;

basis/concurrency/count-downs/count-downs.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: dlists kernel math concurrency.promises
-concurrency.mailboxes debugger accessors ;
+concurrency.mailboxes debugger accessors fry ;
 IN: concurrency.count-downs
 
 ! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html
@@ -26,12 +26,12 @@ ERROR: count-down-already-done ;
     [ 1- >>n count-down-check ] if ;
 
 : await-timeout ( count-down timeout -- )
-    >r promise>> r> ?promise-timeout ?linked t assert= ;
+    [ promise>> ] dip ?promise-timeout ?linked t assert= ;
 
 : await ( count-down -- )
     f await-timeout ;
 
 : spawn-stage ( quot count-down -- )
-    [ [ count-down ] curry compose ] keep
+    [ '[ @ _ count-down ] ] keep
     "Count down stage"
     swap promise>> mailbox>> spawn-linked-to drop ;

basis/concurrency/distributed/distributed-tests.factor

@@ -15,7 +15,7 @@ concurrency.messaging continuations accessors prettyprint ;
 
 [ ] [
     [
-        receive first2 >r 3 + r> send
+        receive first2 [ 3 + ] dip send
         "thread-a" unregister-process
     ] "Thread A" spawn
     "thread-a" swap register-process

basis/concurrency/exchangers/exchangers.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel threads boxes accessors ;
+USING: kernel threads boxes accessors fry ;
 IN: concurrency.exchangers
 
 ! Motivated by
@@ -14,8 +14,8 @@ TUPLE: exchanger thread object ;
 : exchange ( obj exchanger -- newobj )
     dup thread>> occupied>> [
         dup object>> box>
-        >r thread>> box> resume-with r>
+        [ thread>> box> resume-with ] dip
     ] [
         [ object>> >box ] keep
-        [ thread>> >box ] curry "exchange" suspend
+        '[ _ thread>> >box ] "exchange" suspend
     ] if ;

basis/concurrency/flags/flags-tests.factor

@@ -2,7 +2,7 @@ IN: concurrency.flags.tests
 USING: tools.test concurrency.flags concurrency.combinators
 kernel threads locals accessors calendar ;
 
-:: flag-test-1 ( -- )
+:: flag-test-1 ( -- val )
     [let | f [ <flag> ] |
         [ f raise-flag ] "Flag test" spawn drop
         f lower-flag
@@ -20,7 +20,7 @@ kernel threads locals accessors calendar ;
 
 [ f ] [ flag-test-2 ] unit-test
 
-:: flag-test-3 ( -- )
+:: flag-test-3 ( -- val )
     [let | f [ <flag> ] |
         f raise-flag
         f value>>
@@ -28,7 +28,7 @@ kernel threads locals accessors calendar ;
 
 [ t ] [ flag-test-3 ] unit-test
 
-:: flag-test-4 ( -- )
+:: flag-test-4 ( -- val )
     [let | f [ <flag> ] |
         [ f raise-flag ] "Flag test" spawn drop
         f wait-for-flag
@@ -37,7 +37,7 @@ kernel threads locals accessors calendar ;
 
 [ t ] [ flag-test-4 ] unit-test
 
-:: flag-test-5 ( -- )
+:: flag-test-5 ( -- val )
     [let | f [ <flag> ] |
         [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
         f wait-for-flag

basis/concurrency/flags/flags.factor

@@ -11,7 +11,7 @@ TUPLE: flag value threads ;
     dup value>> [ drop ] [ t >>value threads>> notify-all ] if ;
 
 : wait-for-flag-timeout ( flag timeout -- )
-    over value>> [ 2drop ] [ >r threads>> r> "flag" wait ] if ;
+    over value>> [ 2drop ] [ [ threads>> ] dip "flag" wait ] if ;
 
 : wait-for-flag ( flag -- )
     f wait-for-flag-timeout ;

basis/concurrency/futures/futures.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: concurrency.promises concurrency.mailboxes kernel arrays
-continuations accessors ;
+continuations accessors fry ;
 IN: concurrency.futures
 
 : future ( quot -- future )
     <promise> [
-        [ [ >r call r> fulfill ] 2curry "Future" ] keep
+        [ '[ @ _ fulfill ] "Future" ] keep
         mailbox>> spawn-linked-to drop
     ] keep ; inline
 

basis/concurrency/locks/locks-tests.factor

@@ -3,7 +3,7 @@ USING: tools.test concurrency.locks concurrency.count-downs
 concurrency.messaging concurrency.mailboxes locals kernel
 threads sequences calendar accessors ;
 
-:: lock-test-0 ( -- )
+:: lock-test-0 ( -- v )
     [let | v [ V{ } clone ]
            c [ 2 <count-down> ] |
 
@@ -27,7 +27,7 @@ threads sequences calendar accessors ;
            v
     ] ;
 
-:: lock-test-1 ( -- )
+:: lock-test-1 ( -- v )
     [let | v [ V{ } clone ]
            l [ <lock> ]
            c [ 2 <count-down> ] |
@@ -79,7 +79,7 @@ threads sequences calendar accessors ;
 
 [ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
 
-:: rw-lock-test-1 ( -- )
+:: rw-lock-test-1 ( -- v )
     [let | l [ <rw-lock> ]
            c [ 1 <count-down> ]
            c' [ 1 <count-down> ]
@@ -129,7 +129,7 @@ threads sequences calendar accessors ;
 
 [ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test
 
-:: rw-lock-test-2 ( -- )
+:: rw-lock-test-2 ( -- v )
     [let | l [ <rw-lock> ]
            c [ 1 <count-down> ]
            c' [ 2 <count-down> ]
@@ -160,7 +160,7 @@ threads sequences calendar accessors ;
 [ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
 
 ! Test lock timeouts
-:: lock-timeout-test ( -- )
+:: lock-timeout-test ( -- v )
     [let | l [ <lock> ] |
         [
             l [ 1 seconds sleep ] with-lock
@@ -177,19 +177,6 @@ threads sequences calendar accessors ;
     thread>> name>> "Lock timeout-er" =
 ] must-fail-with
 
-:: read/write-test ( -- )
-    [let | l [ <lock> ] |
-        [
-            l [ 1 seconds sleep ] with-lock
-        ] "Lock holder" spawn drop
-
-        [
-            l 1/10 seconds [ ] with-lock-timeout
-        ] "Lock timeout-er" spawn-linked drop
-
-        receive
-    ] ;
-
 [
     <rw-lock> dup [
         1 seconds [ ] with-write-lock-timeout

basis/concurrency/locks/locks.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: deques dlists kernel threads continuations math
-concurrency.conditions combinators.short-circuit accessors ;
+concurrency.conditions combinators.short-circuit accessors
+locals ;
 IN: concurrency.locks
 
 ! Simple critical sections
@@ -17,16 +18,16 @@ TUPLE: lock threads owner reentrant? ;
 
 : acquire-lock ( lock timeout -- )
     over owner>>
-    [ 2dup >r threads>> r> "lock" wait ] when drop
+    [ 2dup [ threads>> ] dip "lock" wait ] when drop
     self >>owner drop ;
 
 : release-lock ( lock -- )
     f >>owner
     threads>> notify-1 ;
 
-: do-lock ( lock timeout quot acquire release -- )
+:: do-lock ( lock timeout quot acquire release -- )
-    >r >r pick rot r> call ! use up  timeout acquire
+    lock timeout acquire call
-    swap r> curry [ ] cleanup ; inline
+    quot lock release curry [ ] cleanup ; inline
 
 : (with-lock) ( lock timeout quot -- )
     [ acquire-lock ] [ release-lock ] do-lock ; inline
@@ -60,7 +61,7 @@ TUPLE: rw-lock readers writers reader# writer ;
 
 : acquire-read-lock ( lock timeout -- )
     over writer>>
-    [ 2dup >r readers>> r> "read lock" wait ] when drop
+    [ 2dup [ readers>> ] dip "read lock" wait ] when drop
     add-reader ;
 
 : notify-writer ( lock -- )
@@ -75,7 +76,7 @@ TUPLE: rw-lock readers writers reader# writer ;
 
 : acquire-write-lock ( lock timeout -- )
     over writer>> pick reader#>> 0 > or
-    [ 2dup >r writers>> r> "write lock" wait ] when drop
+    [ 2dup [ writers>> ] dip "write lock" wait ] when drop
     self >>writer drop ;
 
 : release-write-lock ( lock -- )

basis/concurrency/mailboxes/mailboxes.factor

@@ -4,7 +4,7 @@ IN: concurrency.mailboxes
 USING: dlists deques threads sequences continuations
 destructors namespaces math quotations words kernel
 arrays assocs init system concurrency.conditions accessors
-debugger debugger.threads locals ;
+debugger debugger.threads locals fry ;
 
 TUPLE: mailbox threads data disposed ;
 
@@ -21,7 +21,7 @@ M: mailbox dispose* threads>> notify-all ;
     [ threads>> notify-all ] bi yield ;
 
 : wait-for-mailbox ( mailbox timeout -- )
-    >r threads>> r> "mailbox" wait ;
+    [ threads>> ] dip "mailbox" wait ;
 
 :: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
     mailbox check-disposed
@@ -57,11 +57,11 @@ M: mailbox dispose* threads>> notify-all ;
     f mailbox-get-all-timeout ;
 
 : while-mailbox-empty ( mailbox quot -- )
-    [ [ mailbox-empty? ] curry ] dip [ ] while ; inline
+    [ '[ _ mailbox-empty? ] ] dip [ ] while ; inline
 
 : mailbox-get-timeout? ( mailbox timeout pred -- obj )
     [ block-unless-pred ]
-    [ nip >r data>> r> delete-node-if ]
+    [ [ drop data>> ] dip delete-node-if ]
     3bi ; inline
 
 : mailbox-get? ( mailbox pred -- obj )
@@ -90,7 +90,7 @@ M: linked-thread error-in-thread
     [ <linked-error> ] [ supervisor>> ] bi mailbox-put ;
 
 : <linked-thread> ( quot name mailbox -- thread' )
-    >r linked-thread new-thread r> >>supervisor ;
+    [ linked-thread new-thread ] dip >>supervisor ;
 
 : spawn-linked-to ( quot name mailbox -- thread )
     <linked-thread> [ (spawn) ] keep ;

basis/concurrency/messaging/messaging-docs.factor

@@ -55,7 +55,7 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
 { $example
     "USING: concurrency.messaging kernel threads ;"
     ": pong-server ( -- )"
-    "    receive >r \"pong\" r> reply-synchronous ;"
+    "    receive [ \"pong\" ] dip reply-synchronous ;"
     "[ pong-server t ] \"pong-server\" spawn-server"
     "\"ping\" swap send-synchronous ."
     "\"pong\""

basis/concurrency/messaging/messaging.factor

@@ -1,10 +1,7 @@
 ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-!
-! Concurrency library for Factor, based on Erlang/Termite style
-! concurrency.
 USING: kernel threads concurrency.mailboxes continuations
-namespaces assocs accessors summary ;
+namespaces assocs accessors summary fry ;
 IN: concurrency.messaging
 
 GENERIC: send ( message thread -- )
@@ -32,7 +29,7 @@ M: thread send ( message thread -- )
     my-mailbox -rot mailbox-get-timeout? ?linked ; inline
 
 : rethrow-linked ( error process supervisor -- )
-    >r <linked-error> r> send ;
+    [ <linked-error> ] dip send ;
 
 : spawn-linked ( quot name -- thread )
     my-mailbox spawn-linked-to ;
@@ -48,9 +45,7 @@ TUPLE: reply data tag ;
     tag>> \ reply boa ;
 
 : synchronous-reply? ( response synchronous -- ? )
-    over reply?
+    over reply? [ [ tag>> ] bi@ = ] [ 2drop f ] if ;
-    [ >r tag>> r> tag>> = ]
-    [ 2drop f ] if ;
 
 ERROR: cannot-send-synchronous-to-self message thread ;
 
@@ -61,8 +56,8 @@ M: cannot-send-synchronous-to-self summary
     dup self eq? [
         cannot-send-synchronous-to-self
     ] [
-        >r <synchronous> dup r> send
+        [ <synchronous> dup ] dip send
-        [ synchronous-reply? ] curry receive-if
+        '[ _ synchronous-reply? ] receive-if
         data>>
     ] if ;
 

basis/concurrency/promises/promises.factor

@@ -20,7 +20,7 @@ ERROR: promise-already-fulfilled promise ;
     ] if ;
 
 : ?promise-timeout ( promise timeout -- result )
-    >r mailbox>> r> block-if-empty mailbox-peek ;
+    [ mailbox>> ] dip block-if-empty mailbox-peek ;
 
 : ?promise ( promise -- result )
     f ?promise-timeout ;

basis/concurrency/semaphores/semaphores.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: dlists kernel threads math concurrency.conditions
-continuations accessors summary ;
+continuations accessors summary locals fry ;
 IN: concurrency.semaphores
 
 TUPLE: semaphore count threads ;
@@ -30,9 +30,9 @@ M: negative-count-semaphore summary
     [ 1+ ] change-count
     threads>> notify-1 ;
 
-: with-semaphore-timeout ( semaphore timeout quot -- )
+:: with-semaphore-timeout ( semaphore timeout quot -- )
-    pick rot acquire-timeout swap
+    semaphore timeout acquire-timeout
-    [ release ] curry [ ] cleanup ; inline
+    quot [ semaphore release ] [ ] cleanup ; inline
 
 : with-semaphore ( semaphore quot -- )
-    over acquire swap [ release ] curry [ ] cleanup ; inline
+    swap dup acquire '[ _ release ] [ ] cleanup ; inline

basis/io/pipes/pipes.factor

@@ -15,9 +15,10 @@ HOOK: (pipe) io-backend ( -- pipe )
 
 : <pipe> ( encoding -- stream )
     [
-        >r (pipe) |dispose
+        [
-        [ in>> <input-port> ] [ out>> <output-port> ] bi
+            (pipe) |dispose
-        r> <encoder-duplex>
+            [ in>> <input-port> ] [ out>> <output-port> ] bi
+        ] dip <encoder-duplex>
     ] with-destructors ;
 
 <PRIVATE
@@ -32,8 +33,7 @@ GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot )
 
 M: callable run-pipeline-element
     [
-        >r [ ?reader ] [ ?writer ] bi*
+        [ [ ?reader ] [ ?writer ] bi* ] dip with-streams*
-        r> with-streams*
     ] with-destructors ;
 
 : <pipes> ( n -- pipes )
@@ -48,8 +48,8 @@ PRIVATE>
 : run-pipeline ( seq -- results )
     [ length dup zero? [ drop { } ] [ 1- <pipes> ] if ] keep
     [
-        >r [ first in>> ] [ second out>> ] bi
+        [ [ first in>> ] [ second out>> ] bi ] dip
-        r> run-pipeline-element
+        run-pipeline-element
     ] 2parallel-map ;
 
 {