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

basis/compiler/tree/cleanup/cleanup-tests.factor

@@ -71,7 +71,7 @@ M: object xyz ;
     2over fixnum>= [
         3drop
     ] [
-        [ swap >r call 1 fixnum+fast r> ] keep (fx-repeat)
+        [ swap [ call 1 fixnum+fast ] dip ] keep (fx-repeat)
     ] if ; inline recursive
 
 : fx-repeat ( n quot -- )
@@ -87,10 +87,10 @@ M: object xyz ;
     2over dup xyz drop >= [
         3drop
     ] [
-        [ swap >r call 1+ r> ] keep (i-repeat)
+        [ swap [ call 1+ ] dip ] keep (i-repeat)
     ] if ; inline recursive
 
-: i-repeat >r { integer } declare r> 0 -rot (i-repeat) ; inline
+: i-repeat [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
 
 [ t ] [
     [ [ dup xyz drop ] i-repeat ] \ xyz inlined?
@@ -194,7 +194,7 @@ M: fixnum annotate-entry-test-1 drop ;
     2dup >= [
         2drop
     ] [
-        >r dup annotate-entry-test-1 1+ r> (annotate-entry-test-2)
+        [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
     ] if ; inline recursive
 
 : annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
@@ -448,7 +448,7 @@ cell-bits 32 = [
 ] unit-test
 
 [ ] [
-    [ [ >r "A" throw r> ] [ "B" throw ] if ]
+    [ [ [ "A" throw ] dip ] [ "B" throw ] if ]
     cleaned-up-tree drop
 ] unit-test
 
@@ -463,7 +463,7 @@ cell-bits 32 = [
 : buffalo-wings ( i seq -- )
     2dup < [
         2dup chicken-fingers
-        >r 1+ r> buffalo-wings
+        [ 1+ ] dip buffalo-wings
     ] [
         2drop
     ] if ; inline recursive
@@ -482,7 +482,7 @@ cell-bits 32 = [
 : ribs ( i seq -- )
     2dup < [
         steak
-        >r 1+ r> ribs
+        [ 1+ ] dip ribs
     ] [
         2drop
     ] if ; inline recursive

basis/compiler/tree/dead-code/dead-code-tests.factor

@@ -75,9 +75,9 @@ IN: compiler.tree.dead-code.tests
     remove-dead-code
     "no-check" get [ dup check-nodes ] unless nodes>quot ;
 
-[ [ drop 1 ] ] [ [ >r 1 r> drop ] optimize-quot ] unit-test
+[ [ drop 1 ] ] [ [ [ 1 ] dip drop ] optimize-quot ] unit-test
 
-[ [ read drop 1 2 ] ] [ [ read >r 1 2 r> drop ] optimize-quot ] unit-test
+[ [ read drop 1 2 ] ] [ [ read [ 1 2 ] dip drop ] optimize-quot ] unit-test
 
 [ [ over >r + r> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
 

basis/compiler/tree/normalization/normalization-tests.factor

@@ -34,8 +34,8 @@ sequences accessors tools.test kernel math ;
 [ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
 
 DEFER: bbb
-: aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive
+: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
-: bbb ( x -- ) >r drop 0 r> aaa ; inline recursive
+: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive
 
 [ ] [ [ bbb ] test-normalization ] unit-test
 

basis/compiler/tree/propagation/propagation-tests.factor

@@ -435,7 +435,7 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
 ] unit-test
 
 : recursive-test-4 ( i n -- )
-    2dup < [ >r 1+ r> recursive-test-4 ] [ 2drop ] if ; inline recursive
+    2dup < [ [ 1+ ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive
 
 [ ] [ [ recursive-test-4 ] final-info drop ] unit-test
 

basis/cpu/x86/x86.factor

@@ -561,7 +561,7 @@ M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ;
 
 M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
 
-M: int-regs %save-param-reg drop >r param@ r> MOV ;
+M: int-regs %save-param-reg drop [ param@ ] dip MOV ;
 M: int-regs %load-param-reg drop swap param@ MOV ;
 
 GENERIC: MOVSS/D ( dst src reg-class -- )
@@ -569,8 +569,8 @@ GENERIC: MOVSS/D ( dst src reg-class -- )
 M: single-float-regs MOVSS/D drop MOVSS ;
 M: double-float-regs MOVSS/D drop MOVSD ;
 
-M: float-regs %save-param-reg >r >r param@ r> r> MOVSS/D ;
+M: float-regs %save-param-reg [ param@ ] 2dip MOVSS/D ;
-M: float-regs %load-param-reg >r swap param@ r> MOVSS/D ;
+M: float-regs %load-param-reg [ swap param@ ] dip MOVSS/D ;
 
 GENERIC: push-return-reg ( reg-class -- )
 GENERIC: load-return-reg ( n reg-class -- )

basis/debugger/debugger-docs.factor

@@ -131,11 +131,11 @@ HELP: datastack-overflow.
 { $notes "This error usually indicates a run-away recursion, however if you legitimately need a data stack larger than the default, see " { $link "runtime-cli-args" } "." } ;
 
 HELP: retainstack-underflow.
-{ $error-description "Thrown by the Factor VM if " { $link r> } " is called while the retain stack is empty." }
+{ $error-description "Thrown by the Factor VM if an attempt is made to access the retain stack in an invalid manner. This bug should never come up in practice and indicates a bug in Factor." }
 { $notes "You can use the stack effect tool to statically check stack effects of quotations. See " { $link "inference" } "." } ;
 
 HELP: retainstack-overflow.
-{ $error-description "Thrown by the Factor VM if " { $link >r } " is called when the retain stack is full." }
+{ $error-description "Thrown by the Factor VM if " { $link dip } " is called when the retain stack is full." }
 { $notes "This error usually indicates a run-away recursion, however if you legitimately need a retain stack larger than the default, see " { $link "runtime-cli-args" } "." } ;
 
 HELP: memory-error.

basis/debugger/debugger.factor

@@ -3,13 +3,13 @@
 USING: slots arrays definitions generic hashtables summary io
 kernel math namespaces make prettyprint prettyprint.config
 sequences assocs sequences.private strings io.styles io.files
-vectors words system splitting math.parser classes.tuple
+vectors words system splitting math.parser classes.mixin
-continuations continuations.private combinators generic.math
+classes.tuple continuations continuations.private combinators
-classes.builtin classes compiler.units generic.standard vocabs
+generic.math classes.builtin classes compiler.units
-init kernel.private io.encodings accessors math.order
+generic.standard vocabs init kernel.private io.encodings
-destructors source-files parser classes.tuple.parser
+accessors math.order destructors source-files parser
-effects.parser lexer compiler.errors generic.parser
+classes.tuple.parser effects.parser lexer compiler.errors
-strings.parser ;
+generic.parser strings.parser ;
 IN: debugger
 
 GENERIC: error. ( error -- )
@@ -327,3 +327,5 @@ M: bad-effect summary
 M: bad-escape summary drop "Bad escape code" ;
 
 M: bad-literal-tuple summary drop "Bad literal tuple" ;
+
+M: check-mixin-class summary drop "Not a mixin class" ;

basis/help/markup/markup.factor

@@ -97,7 +97,7 @@ ALIAS: $slot $snippet
     [
         snippet-style get [
             last-element off
-            >r ($code-style) r> with-nesting
+            [ ($code-style) ] dip with-nesting
         ] with-style
     ] ($block) ; inline
 

basis/help/syntax/syntax.factor

@@ -11,9 +11,10 @@ IN: help.syntax
     \ ; parse-until >array swap set-word-help ; parsing
 
 : ARTICLE:
-    location >r
+    location [
-    \ ; parse-until >array [ first2 ] keep 2 tail <article>
+        \ ; parse-until >array [ first2 ] keep 2 tail <article>
-    over add-article >link r> remember-definition ; parsing
+        over add-article >link
+    ] dip remember-definition ; parsing
 
 : ABOUT:
     in get vocab

basis/html/elements/elements.factor

@@ -24,7 +24,7 @@ SYMBOL: html
 : html-word ( name def effect -- )
     #! Define 'word creating' word to allow
     #! dynamically creating words.
-    >r >r elements-vocab create r> r> define-declared ;
+    [ elements-vocab create ] 2dip define-declared ;
 
 : <foo> ( str -- <str> ) "<" swap ">" 3append ;
 

basis/html/streams/streams.factor

@@ -77,7 +77,7 @@ TUPLE: html-sub-stream < html-stream style parent ;
     "font-family: " % % "; " % ;
 
 : apply-style ( style key quot -- style gadget )
-    >r over at r> when* ; inline
+    [ over at ] dip when* ; inline
 
 : make-css ( style quot -- str )
     "" make nip ; inline
@@ -163,13 +163,13 @@ M: html-stream stream-flush
     stream>> stream-flush ;
 
 M: html-stream stream-write1
-    >r 1string r> stream-write ;
+    [ 1string ] dip stream-write ;
 
 M: html-stream stream-write
-    not-a-div >r escape-string r> stream>> stream-write ;
+    not-a-div [ escape-string ] dip stream>> stream-write ;
 
 M: html-stream stream-format
-    >r html over at [ >r escape-string r> ] unless r>
+    [ html over at [ [ escape-string ] dip ] unless ] dip
     format-html-span ;
 
 M: html-stream stream-nl

basis/interval-maps/interval-maps.factor

@@ -15,7 +15,7 @@ TUPLE: interval-map array ;
     first2 between? ;
 
 : all-intervals ( sequence -- intervals )
-    [ >r dup number? [ dup 2array ] when r> ] { } assoc-map-as ;
+    [ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ;
 
 : disjoint? ( node1 node2 -- ? )
     [ second ] [ first ] bi* < ;

basis/io/windows/nt/privileges/privileges.factor

@@ -42,7 +42,6 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
     [ lookup-privilege ] dip
     [
         TOKEN_PRIVILEGES-Privileges
-        [ 0 ] dip LUID_AND_ATTRIBUTES-nth
         set-LUID_AND_ATTRIBUTES-Luid
     ] keep ;
 

basis/logging/analysis/analysis.factor

@@ -38,8 +38,8 @@ SYMBOL: message-histogram
 
 : histogram. ( assoc quot -- )
     standard-table-style [
-        >r >alist sort-values <reversed> r> [
+        [ >alist sort-values <reversed> ] dip [
-            [ >r swap r> with-cell pprint-cell ] with-row
+            [ swapd with-cell pprint-cell ] with-row
         ] curry assoc-each
     ] tabular-output ;
 
@@ -69,7 +69,7 @@ SYMBOL: message-histogram
     errors. ;
 
 : analyze-log ( lines word-names -- )
-    >r parse-log r> analyze-entries analysis. ;
+    [ parse-log ] dip analyze-entries analysis. ;
 
 : analyze-log-file ( service word-names -- )
-    >r parse-log-file r> analyze-entries analysis. ;
+    [ parse-log-file ] dip analyze-entries analysis. ;

basis/match/match.factor

@@ -73,7 +73,7 @@ MACRO: match-cond ( assoc -- )
     2dup [ length ] bi@ < [ 2drop f f ]
     [
         2dup length head over match
-        [ nip swap ?1-tail ] [ >r rest r> (match-first) ] if*
+        [ nip swap ?1-tail ] [ [ rest ] dip (match-first) ] if*
     ] if ;
     
 : match-first ( seq pattern-seq -- bindings )

basis/math/geometry/rect/rect.factor

@@ -37,7 +37,7 @@ M: rect rect-dim dim>> ;
     over rect-loc v+ swap rect-dim <rect> ;
 
 : (rect-intersect) ( rect rect -- array array )
-    2rect-extent vmin >r vmax r> ;
+    2rect-extent [ vmax ] [ vmin ] 2bi* ;
 
 : rect-intersect ( rect1 rect2 -- newrect )
     (rect-intersect) <extent-rect> ;
@@ -46,7 +46,7 @@ M: rect rect-dim dim>> ;
     (rect-intersect) [v-] { 0 0 } = ;
 
 : (rect-union) ( rect rect -- array array )
-    2rect-extent vmax >r vmin r> ;
+    2rect-extent [ vmin ] [ vmax ] 2bi* ;
 
 : rect-union ( rect1 rect2 -- newrect )
     (rect-union) <extent-rect> ;

basis/models/history/history.factor

@@ -18,7 +18,7 @@ TUPLE: history < model back forward ;
 
 : go-back/forward ( history to from -- )
     [ 2drop ]
-    [ >r dupd (add-history) r> pop swap set-model ] if-empty ;
+    [ [ dupd (add-history) ] dip pop swap set-model ] if-empty ;
 
 : go-back ( history -- )
     dup [ forward>> ] [ back>> ] bi go-back/forward ;

basis/models/models.factor

@@ -91,7 +91,7 @@ M: model update-model drop ;
     ] if ;
 
 : ((change-model)) ( model quot -- newvalue model )
-    over >r >r value>> r> call r> ; inline
+    over [ [ value>> ] dip call ] dip ; inline
 
 : change-model ( model quot -- )
     ((change-model)) set-model ; inline

basis/multiline/multiline.factor

@@ -28,7 +28,7 @@ PRIVATE>
 : (parse-multiline-string) ( start-index end-text -- end-index )
     lexer get line-text>> [
         2dup start
-        [ rot dupd >r >r swap subseq % r> r> length + ] [
+        [ rot dupd [ swap subseq % ] 2dip length + ] [
             rot tail % "\n" % 0
             lexer get next-line swap (parse-multiline-string)
         ] if*

basis/openssl/libssl/libssl.factor

@@ -234,13 +234,13 @@ FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( SSL_CTX* ctx, void* rsa ) ;
 FUNCTION: void* BIO_f_ssl (  ) ;
 
 : SSL_CTX_set_tmp_rsa ( ctx rsa -- n )
-    >r SSL_CTRL_SET_TMP_RSA 0 r> SSL_CTX_ctrl ;
+    [ SSL_CTRL_SET_TMP_RSA 0 ] dip SSL_CTX_ctrl ;
 
 : SSL_CTX_set_tmp_dh ( ctx dh -- n )
-    >r SSL_CTRL_SET_TMP_DH 0 r> SSL_CTX_ctrl ;
+    [ SSL_CTRL_SET_TMP_DH 0 ] dip SSL_CTX_ctrl ;
 
 : SSL_CTX_set_session_cache_mode ( ctx mode -- n )
-    >r SSL_CTRL_SET_SESS_CACHE_MODE r> f SSL_CTX_ctrl ;
+    [ SSL_CTRL_SET_SESS_CACHE_MODE ] dip f SSL_CTX_ctrl ;
 
 : SSL_SESS_CACHE_OFF                      HEX: 0000 ; inline
 : SSL_SESS_CACHE_CLIENT                   HEX: 0001 ; inline

basis/peg/parsers/parsers.factor

@@ -24,7 +24,7 @@ M: just-parser (compile) ( parser -- quot )
 : 1token ( ch -- parser ) 1string token ;
 
 : (list-of) ( items separator repeat1? -- parser )
-  >r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
+  [ over 2seq ] dip [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
   [ unclip 1vector swap first append ] action ;
 
 : list-of ( items separator -- parser )
@@ -60,11 +60,11 @@ PRIVATE>
   [ flatten-vectors ] action ;
 
 : from-m-to-n ( parser m n -- parser' )
-  >r [ exactly-n ] 2keep r> swap - at-most-n 2seq
+  [ [ exactly-n ] 2keep ] dip swap - at-most-n 2seq
   [ flatten-vectors ] action ;
 
 : pack ( begin body end -- parser )
-  >r >r hide r> r> hide 3seq [ first ] action ;
+  [ hide ] 2dip hide 3seq [ first ] action ;
 
 : surrounded-by ( parser begin end -- parser' )
   [ token ] bi@ swapd pack ;

basis/peg/peg.factor

@@ -146,8 +146,8 @@ TUPLE: peg-head rule-id involved-set eval-set ;
   pos set dup involved-set>> clone >>eval-set drop ;
 
 : (grow-lr) ( h p r: ( -- result ) m -- )
-  >r >r [ setup-growth ] 2keep r> r>
+  [ [ setup-growth ] 2keep ] 2dip
-  >r dup eval-rule r> swap
+  [ dup eval-rule ] dip swap
   dup pick stop-growth? [
     5 ndrop
   ] [
@@ -156,8 +156,8 @@ TUPLE: peg-head rule-id involved-set eval-set ;
   ] if ; inline recursive
  
 : grow-lr ( h p r m -- ast )
-  >r >r [ heads set-at ] 2keep r> r>
+  [ [ heads set-at ] 2keep ] 2dip
-  pick over >r >r (grow-lr) r> r>
+  pick over [ (grow-lr) ] 2dip
   swap heads delete-at
   dup pos>> pos set ans>>
   ; inline
@@ -352,7 +352,7 @@ TUPLE: token-parser symbol ;
   [ ?head-slice ] keep swap [
     <parse-result> f f add-error
   ] [
-    >r drop pos get "token '" r> append "'" append 1vector add-error f
+    [ drop pos get "token '" ] dip append "'" append 1vector add-error f
   ] if ;
 
 M: token-parser (compile) ( peg -- quot )

basis/prettyprint/backend/backend.factor

@@ -21,9 +21,6 @@ M: effect pprint* effect>string "(" swap ")" 3append text ;
 : ?end-group ( word -- )
     ?effect-height 0 < [ end-group ] when ;
 
-\ >r hard "break-before" set-word-prop
-\ r> hard "break-after" set-word-prop
-
 ! Atoms
 : word-style ( word -- style )
     dup "word-style" word-prop >hashtable [
@@ -93,7 +90,7 @@ M: f pprint* drop \ f pprint-word ;
     ] H{ } make-assoc ;
 
 : unparse-string ( str prefix suffix -- str )
-    [ >r % do-string-limit [ unparse-ch ] each r> % ] "" make ;
+    [ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;
 
 : pprint-string ( obj str prefix suffix -- )
     unparse-string swap string-style styled-text ;
@@ -156,13 +153,13 @@ M: tuple pprint*
 : do-length-limit ( seq -- trimmed n/f )
     length-limit get dup [
         over length over [-]
-        dup zero? [ 2drop f ] [ >r head r> ] if
+        dup zero? [ 2drop f ] [ [ head ] dip ] if
     ] when ;
 
 : pprint-elements ( seq -- )
-    do-length-limit >r
+    do-length-limit
-    [ pprint* ] each
+    [ [ pprint* ] each ] dip
-    r> [ "~" swap number>string " more~" 3append text ] when* ;
+    [ "~" swap number>string " more~" 3append text ] when* ;
 
 GENERIC: pprint-delims ( obj -- start end )
 
@@ -206,10 +203,12 @@ M: tuple pprint-narrow? drop t ;
 : pprint-object ( obj -- )
     [
         <flow
-        dup pprint-delims >r pprint-word
+        dup pprint-delims [
-        dup pprint-narrow? <inset
+            pprint-word
-        >pprint-sequence pprint-elements
+            dup pprint-narrow? <inset
-        block> r> pprint-word block>
+            >pprint-sequence pprint-elements
+            block>
+        ] dip pprint-word block>
     ] check-recursion ;
 
 M: object pprint* pprint-object ;

basis/prettyprint/prettyprint-tests.factor

@@ -135,20 +135,6 @@ M: object method-layout ;
     [ \ method-layout see-methods ] with-string-writer "\n" split
 ] unit-test
 
-: retain-stack-test
-    {
-        "USING: io kernel sequences words ;"
-        "IN: prettyprint.tests"
-        ": retain-stack-layout ( x -- )"
-        "    dup stream-readln stream-readln"
-        "    >r [ define ] map r>"
-        "    define ;"
-    } ;
-
-[ t ] [
-    "retain-stack-layout" retain-stack-test check-see
-] unit-test
-
 : soft-break-test
     {
         "USING: kernel math sequences strings ;"
@@ -164,19 +150,6 @@ M: object method-layout ;
     "soft-break-layout" soft-break-test check-see
 ] unit-test
 
-: another-retain-layout-test
-    {
-        "USING: kernel sequences ;"
-        "IN: prettyprint.tests"
-        ": another-retain-layout ( seq1 seq2 quot -- newseq )"
-        "    -rot 2dup dupd min-length [ each drop roll ] map"
-        "    >r 3drop r> ; inline"
-    } ;
-
-[ t ] [
-    "another-retain-layout" another-retain-layout-test check-see
-] unit-test
-
 DEFER: parse-error-file
 
 : another-soft-break-test
@@ -219,8 +192,7 @@ DEFER: parse-error-file
         "USING: kernel sequences ;"
         "IN: prettyprint.tests"
         ": final-soft-break-layout ( class dim -- view )"
-        "    >r \"alloc\" send 0 0 r>"
+        "    [ \"alloc\" send 0 0 ] dip first2 <NSRect>"
-        "    first2 <NSRect>"
         "    <PixelFormat> \"initWithFrame:pixelFormat:\" send"
         "    dup 1 \"setPostsBoundsChangedNotifications:\" send"
         "    dup 1 \"setPostsFrameChangedNotifications:\" send ;"

basis/prettyprint/sections/sections.factor

@@ -42,7 +42,7 @@ TUPLE: pprinter last-newline line-count indent ;
 
 : text-fits? ( len -- ? )
     margin get dup zero?
-    [ 2drop t ] [ >r pprinter get indent>> + r> <= ] if ;
+    [ 2drop t ] [ [ pprinter get indent>> + ] dip <= ] if ;
 
 ! break only if position margin 2 / >
 SYMBOL: soft
@@ -189,7 +189,7 @@ M: block short-section ( block -- )
 : empty-block? ( block -- ? ) sections>> empty? ;
 
 : if-nonempty ( block quot -- )
-    >r dup empty-block? [ drop ] r> if ; inline
+    [ dup empty-block? [ drop ] ] dip if ; inline
 
 : (<block) ( block -- ) pprinter-stack get push ;
 

basis/sequences/next/next.factor

@@ -3,20 +3,18 @@ IN: sequences.next
 
 <PRIVATE
 
-: iterate-seq >r dup length swap r> ; inline
+: iterate-seq [ dup length swap ] dip ; inline
 
 : (map-next) ( i seq quot -- )
     ! this uses O(n) more bounds checks than is really necessary
-    >r [ >r 1+ r> ?nth ] 2keep nth-unsafe r> call ; inline
+    [ [ [ 1+ ] dip ?nth ] 2keep nth-unsafe ] dip call ; inline
 
 PRIVATE>
 
-: each-next ( seq quot -- )
+: each-next ( seq quot: ( next-elt elt -- ) -- )
-    ! quot: next-elt elt --
     iterate-seq [ (map-next) ] 2curry each-integer ; inline
 
-: map-next ( seq quot -- newseq )
+: map-next ( seq quot: ( next-elt elt -- newelt ) -- newseq )
-    ! quot: next-elt elt -- newelt
+    over dup length swap new-sequence [
-    over dup length swap new-sequence >r
+        iterate-seq [ (map-next) ] 2curry
-    iterate-seq [ (map-next) ] 2curry
+    ] dip [ collect ] keep ; inline
-    r> [ collect ] keep ; inline

basis/shuffle/shuffle-tests.factor

@@ -2,3 +2,4 @@ USING: shuffle tools.test ;
 
 [ 8 ] [ 5 6 7 8 3nip ] unit-test
 [ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test
+[ 1 2 3 4 ] [ 3 4 1 2 2swap ] unit-test

basis/shuffle/shuffle.factor

@@ -4,7 +4,7 @@ USING: kernel generalizations ;
 
 IN: shuffle
 
-: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
+: 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline
 
 : nipd ( a b c -- b c ) rot drop ; inline
 

basis/stack-checker/errors/errors-docs.factor

@@ -115,7 +115,6 @@ ARTICLE: "inference-errors" "Inference warnings and errors"
 { $subsection inconsistent-recursive-call-error }
 "Retain stack usage errors:"
 { $subsection too-many->r }
-{ $subsection too-many-r> }
+{ $subsection too-many-r> } ;
-"See " { $link "shuffle-words" } " for retain stack usage conventions. This error can only occur if your code calls " { $link >r } " and " { $link r> } " directly. The " { $link dip } " combinator is safer to use because there is no way to leave the retain stack in an unbalanced state." ;
 
 ABOUT: "inference-errors"

basis/stack-checker/errors/errors.factor

@@ -13,7 +13,7 @@ M: inference-error compiler-error-type type>> ;
 M: inference-error error-help error>> error-help ;
 
 : (inference-error) ( ... class type -- * )
-    >r boa r>
+    [ boa ] dip
     recursive-state get word>>
     \ inference-error boa throw ; inline
 

basis/struct-arrays/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/struct-arrays/struct-arrays-docs.factor

@@ -0,0 +1,23 @@
+IN: struct-arrays
+USING: help.markup help.syntax alien strings math ;
+
+HELP: struct-array
+{ $class-description "The class of C struct and union arrays."
+$nl
+"The " { $slot "underlying" } " slot holds a " { $link c-ptr } " with the raw data. This pointer can be passed to C functions." } ;
+
+HELP: <struct-array>
+{ $values { "length" integer } { "c-type" string } }
+{ $description "Creates a new array for holding values of the specified C type." } ;
+
+HELP: <direct-struct-array>
+{ $values { "alien" c-ptr } { "length" integer } { "c-type" string } }
+{ $description "Creates a new array for holding values of the specified C type, backed by the memory at " { $snippet "alien" } "." } ;
+
+ARTICLE: "struct-arrays" "C struct and union arrays"
+"The " { $vocab-link "struct-arrays" } " vocabulary implements arrays specialized for holding C struct and union values."
+{ $subsection struct-array }
+{ $subsection <struct-array> }
+{ $subsection <direct-struct-array> } ;
+
+ABOUT: "struct-arrays"

basis/struct-arrays/struct-arrays-tests.factor

@@ -0,0 +1,29 @@
+IN: struct-arrays.tests
+USING: struct-arrays tools.test kernel math sequences
+alien.syntax alien.c-types destructors libc accessors ;
+
+C-STRUCT: test-struct
+{ "int" "x" }
+{ "int" "y" } ;
+
+: make-point ( x y -- struct )
+    "test-struct" <c-object>
+    [ set-test-struct-y ] keep
+    [ set-test-struct-x ] keep ;
+
+[ 5/4 ] [
+    2 "test-struct" <struct-array>
+    1 2 make-point over set-first
+    3 4 make-point over set-second
+    0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce
+] unit-test
+
+[ 5/4 ] [
+    [
+        2 "test-struct" malloc-struct-array
+        dup underlying>> &free drop
+        1 2 make-point over set-first
+        3 4 make-point over set-second
+        0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce
+    ] with-destructors
+] unit-test

basis/struct-arrays/struct-arrays.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types byte-arrays kernel libc
+math sequences sequences.private ;
+IN: struct-arrays
+
+TUPLE: struct-array
+{ underlying c-ptr read-only }
+{ length array-capacity read-only }
+{ element-size array-capacity read-only } ;
+
+M: struct-array length length>> ;
+
+M: struct-array nth-unsafe
+    [ element-size>> * ] [ underlying>> ] bi <displaced-alien> ;
+
+M: struct-array set-nth-unsafe
+    [ nth-unsafe swap ] [ element-size>> ] bi memcpy ;
+
+M: struct-array new-sequence
+    element-size>> [ * <byte-array> ] 2keep struct-array boa ; inline
+
+: <struct-array> ( length c-type -- struct-array )
+    heap-size [ * <byte-array> ] 2keep struct-array boa ; inline
+
+ERROR: bad-byte-array-length byte-array ;
+
+: byte-array>struct-array ( byte-array c-type -- struct-array )
+    heap-size [
+        [ dup length ] dip /mod 0 =
+        [ drop bad-byte-array-length ] unless
+    ] keep struct-array boa ; inline
+
+: <direct-struct-array> ( alien length c-type -- struct-array )
+    struct-array boa ; inline
+
+: malloc-struct-array ( length c-type -- struct-array )
+    heap-size [ calloc ] 2keep <direct-struct-array> ;
+
+INSTANCE: struct-array sequence

basis/struct-arrays/summary.txt

@@ -0,0 +1 @@
+Arrays of C structs and unions

basis/struct-arrays/tags.txt

@@ -0,0 +1 @@
+collections

basis/threads/threads.factor

@@ -4,7 +4,7 @@
 USING: arrays hashtables heaps kernel kernel.private math
 namespaces sequences vectors continuations continuations.private
 dlists assocs system combinators init boxes accessors
-math.order deques strings quotations ;
+math.order deques strings quotations fry ;
 IN: threads
 
 SYMBOL: initial-thread
@@ -101,7 +101,7 @@ DEFER: stop
 <PRIVATE
 
 : schedule-sleep ( thread dt -- )
-    >r check-registered dup r> sleep-queue heap-push*
+    [ check-registered dup ] dip sleep-queue heap-push*
     >>sleep-entry drop ;
 
 : expire-sleep? ( heap -- ? )
@@ -164,10 +164,8 @@ PRIVATE>
 
 : suspend ( quot state -- obj )
     [
-        >r
+        [ [ self swap call ] dip self (>>state) ] dip
-        >r self swap call
+        self continuation>> >box
-        r> self (>>state)
-        r> self continuation>> >box
         next
     ] callcc1 2nip ; inline
 
@@ -176,7 +174,7 @@ PRIVATE>
 GENERIC: sleep-until ( time/f -- )
 
 M: integer sleep-until
-    [ schedule-sleep ] curry "sleep" suspend drop ;
+    '[ _ schedule-sleep ] "sleep" suspend drop ;
 
 M: f sleep-until
     drop [ drop ] "interrupt" suspend drop ;
@@ -200,11 +198,11 @@ M: real sleep
     <thread> [ (spawn) ] keep ;
 
 : spawn-server ( quot name -- thread )
-    >r [ loop ] curry r> spawn ;
+    [ '[ _ loop ] ] dip spawn ;
 
 : in-thread ( quot -- )
-    >r datastack r>
+    [ datastack ] dip
-    [ >r set-datastack r> call ] 2curry
+    '[ _ set-datastack _ call ]
     "Thread" spawn drop ;
 
 GENERIC: error-in-thread ( error thread -- )

basis/tools/completion/completion.factor

@@ -33,8 +33,8 @@ IN: tools.completion
     {
         { [ over zero? ] [ 2drop 10 ] }
         { [ 2dup length 1- number= ] [ 2drop 4 ] }
-        { [ 2dup >r 1- r> nth Letter? not ] [ 2drop 10 ] }
+        { [ 2dup [ 1- ] dip nth Letter? not ] [ 2drop 10 ] }
-        { [ 2dup >r 1+ r> nth Letter? not ] [ 2drop 4 ] }
+        { [ 2dup [ 1+ ] dip nth Letter? not ] [ 2drop 4 ] }
         [ 2drop 1 ]
     } cond ;
 
@@ -67,7 +67,7 @@ IN: tools.completion
     over empty? [
         nip [ first ] map
     ] [
-        >r >lower r> [ completion ] with map
+        [ >lower ] dip [ completion ] with map
         rank-completions
     ] if ;
 

basis/tools/deploy/config/config.factor

@@ -76,7 +76,7 @@ SYMBOL: deploy-image
     parse-fresh [ first assoc-union ] unless-empty ;
 
 : set-deploy-config ( assoc vocab -- )
-    >r unparse-use string-lines r>
+    [ unparse-use string-lines ] dip
     dup deploy-config-path set-vocab-file-contents ;
 
 : set-deploy-flag ( value key vocab -- )

basis/tools/deploy/deploy-tests.factor

@@ -7,13 +7,12 @@ urls math.parser ;
 : shake-and-bake ( vocab -- )
     [ "test.image" temp-file delete-file ] ignore-errors
     "resource:" [
-        >r vm
+        [ vm "test.image" temp-file ] dip
-        "test.image" temp-file
+        dup deploy-config make-deploy-image
-        r> dup deploy-config make-deploy-image
     ] with-directory ;
 
 : small-enough? ( n -- ? )
-    >r "test.image" temp-file file-info size>> r> cell 4 / * <= ;
+    [ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;
 
 [ ] [ "hello-world" shake-and-bake ] unit-test
 

basis/tools/memory/memory.factor

@@ -3,7 +3,7 @@
 USING: kernel sequences vectors arrays generic assocs io math
 namespaces parser prettyprint strings io.styles vectors words
 system sorting splitting grouping math.parser classes memory
-combinators ;
+combinators fry ;
 IN: tools.memory
 
 <PRIVATE
@@ -51,9 +51,10 @@ IN: tools.memory
         [ "Largest free block:" write-labelled-size ]
     } spread ;
 
-: heap-stat-step ( counts sizes obj -- )
+: heap-stat-step ( obj counts sizes -- )
-    [ dup size swap class rot at+ ] keep
+    [ over ] dip
-    1 swap class rot at+ ;
+    [ [ [ drop 1 ] [ class ] bi ] dip at+ ]
+    [ [ [ size ] [ class ] bi ] dip at+ ] 2bi* ;
 
 PRIVATE>
 
@@ -71,7 +72,7 @@ PRIVATE>
 
 : heap-stats ( -- counts sizes )
     H{ } clone H{ } clone
-    [ >r 2dup r> heap-stat-step ] each-object ;
+    2dup '[ _ _ heap-stat-step ] each-object ;
 
 : heap-stats. ( -- )
     heap-stats dup keys natural-sort standard-table-style [

basis/tools/profiler/profiler.factor

@@ -34,7 +34,7 @@ M: method-body (profile.)
 
 : counter. ( obj n -- )
     [
-        >r [ (profile.) ] with-cell r>
+        [ [ (profile.) ] with-cell ] dip
         [ number>string write ] with-cell
     ] with-row ;
 

basis/tools/test/test.factor

@@ -3,7 +3,7 @@
 USING: accessors namespaces arrays prettyprint sequences kernel
 vectors quotations words parser assocs combinators continuations
 debugger io io.styles io.files vocabs vocabs.loader source-files
-compiler.units summary stack-checker effects tools.vocabs ;
+compiler.units summary stack-checker effects tools.vocabs fry ;
 IN: tools.test
 
 SYMBOL: failures
@@ -26,24 +26,22 @@ SYMBOL: this-test
     ] if ;
 
 : unit-test ( output input -- )
-    [ 2array ] 2keep [
+    [ 2array ] 2keep '[
-        { } swap with-datastack swap >array assert=
+        _ { } _ with-datastack swap >array assert=
-    ] 2curry (unit-test) ;
+    ] (unit-test) ;
 
 : short-effect ( effect -- pair )
     [ in>> length ] [ out>> length ] bi 2array ;
 
 : must-infer-as ( effect quot -- )
-    >r 1quotation r> [ infer short-effect ] curry unit-test ;
+    [ 1quotation ] dip '[ _ infer short-effect ] unit-test ;
 
 : must-infer ( word/quot -- )
     dup word? [ 1quotation ] when
-    [ infer drop ] curry [ ] swap unit-test ;
+    '[ _ infer drop ] [ ] swap unit-test ;
 
 : must-fail-with ( quot pred -- )
-    >r [ f ] compose r>
+    [ '[ @ f ] ] dip '[ _ _ recover ] [ t ] swap unit-test ;
-    [ recover ] 2curry
-    [ t ] swap unit-test ;
 
 : must-fail ( quot -- )
     [ drop t ] must-fail-with ;

basis/tools/time/time.factor

@@ -5,7 +5,7 @@ namespaces system sequences splitting grouping assocs strings ;
 IN: tools.time
 
 : benchmark ( quot -- runtime )
-    micros >r call micros r> - ; inline
+    micros [ call micros ] dip - ; inline
 
 : time. ( data -- )
     unclip
@@ -37,4 +37,4 @@ IN: tools.time
     ] bi* ;
 
 : time ( quot -- )
-    gc-reset micros >r call gc-stats micros r> - prefix time. ; inline
+    gc-reset micros [ call gc-stats micros ] dip - prefix time. ; inline

basis/tools/vocabs/browser/browser.factor

@@ -250,9 +250,9 @@ C: <vocab-author> vocab-author
 
 : keyed-vocabs ( str quot -- seq )
     all-vocabs [
-        swap >r
+        swap [
-        [ >r 2dup r> swap call member? ] filter
+            [ [ 2dup ] dip swap call member? ] filter
-        r> swap
+        ] dip swap
     ] assoc-map 2nip ; inline
 
 : tagged ( tag -- assoc )

basis/tools/vocabs/vocabs.factor

@@ -203,7 +203,7 @@ M: vocab summary
 M: vocab-link summary vocab-summary ;
 
 : set-vocab-summary ( string vocab -- )
-    >r 1array r>
+    [ 1array ] dip
     dup vocab-summary-path
     set-vocab-file-contents ;
 

basis/unicode/case/case.factor

@@ -5,7 +5,7 @@ unicode.normalize math unicode.categories combinators
 assocs strings splitting kernel accessors ;
 IN: unicode.case
 
-: at-default ( key assoc -- value/key ) over >r at r> or ;
+: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ;
 
 : ch>lower ( ch -- lower ) simple-lower at-default ;
 : ch>upper ( ch -- upper ) simple-upper at-default ;

basis/unicode/data/data.factor

@@ -49,7 +49,7 @@ VALUE: properties
 : (process-data) ( index data -- newdata )
     filter-comments
     [ [ nth ] keep first swap ] with { } map>assoc
-    [ >r hex> r> ] assoc-map ;
+    [ [ hex> ] dip ] assoc-map ;
 
 : process-data ( index data -- hash )
     (process-data) [ hex> ] assoc-map [ nip ] assoc-filter >hashtable ;

basis/unicode/normalize/normalize.factor

@@ -27,14 +27,17 @@ IN: unicode.normalize
 
 : hangul>jamo ( hangul -- jamo-string )
     hangul-base - final-count /mod final-base +
-    >r medial-count /mod medial-base +
+    [
-    >r initial-base + r> r>
+        medial-count /mod medial-base +
+        [ initial-base + ] dip
+    ] dip
     dup final-base = [ drop 2array ] [ 3array ] if ;
 
 : jamo>hangul ( initial medial final -- hangul )
-    >r >r initial-base - medial-count *
+    [
-    r> medial-base - + final-count *
+        [ initial-base - medial-count * ] dip
-    r> final-base - + hangul-base + ;
+        medial-base - + final-count *
+    ] dip final-base - + hangul-base + ;
 
 ! Normalization -- Decomposition 
 
@@ -45,7 +48,7 @@ IN: unicode.normalize
 : reorder-next ( string i -- new-i done? )
     over [ non-starter? ] find-from drop [
         reorder-slice
-        >r dup [ combining-class ] insertion-sort to>> r>
+        [ dup [ combining-class ] insertion-sort to>> ] dip
     ] [ length t ] if* ;
 
 : reorder-loop ( string start -- )

basis/windows/com/wrapper/wrapper.factor

@@ -1,8 +1,9 @@
-USING: alien alien.c-types windows.com.syntax init
+USING: alien alien.c-types alien.accessors windows.com.syntax
-windows.com.syntax.private windows.com continuations kernel
+init windows.com.syntax.private windows.com continuations kernel
 namespaces windows.ole32 libc vocabs assocs accessors arrays
 sequences quotations combinators math words compiler.units
-destructors fry math.parser generalizations sets ;
+destructors fry math.parser generalizations sets
+specialized-arrays.alien specialized-arrays.direct.alien ;
 IN: windows.com.wrapper
 
 TUPLE: com-wrapper callbacks vtbls disposed ;
@@ -51,23 +52,26 @@ unless
         _ case
         [
             "void*" heap-size * rot <displaced-alien> com-add-ref
-            0 rot set-void*-nth S_OK
+            swap 0 set-alien-cell S_OK
-        ] [ nip f 0 rot set-void*-nth E_NOINTERFACE ] if*
+        ] [ nip f swap 0 set-alien-cell E_NOINTERFACE ] if*
     ] ;
 
 : (make-add-ref) ( interfaces -- quot )
     length "void*" heap-size * '[
-        _ swap <displaced-alien>
+        _
-        0 over ulong-nth
+        [ alien-unsigned-4 1+ dup ]
-        1+ [ 0 rot set-ulong-nth ] keep
+        [ set-alien-unsigned-4 ]
+        2bi
     ] ;
 
 : (make-release) ( interfaces -- quot )
     length "void*" heap-size * '[
-        _ over <displaced-alien>
+        _
-        0 over ulong-nth
+        [ drop ]
-        1- [ 0 rot set-ulong-nth ] keep
+        [ alien-unsigned-4 1- dup ]
-        dup zero? [ swap (free-wrapped-object) ] [ nip ] if
+        [ set-alien-unsigned-4 ]
+        2tri
+        dup 0 = [ swap (free-wrapped-object) ] [ nip ] if
     ] ;
 
 : (make-iunknown-methods) ( interfaces -- quots )
@@ -125,8 +129,7 @@ unless
 : (malloc-wrapped-object) ( wrapper -- wrapped-object )
     vtbls>> length "void*" heap-size *
     [ "ulong" heap-size + malloc ] keep
-    over <displaced-alien>
+    [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ;
-    1 0 rot set-ulong-nth ;
 
 : (callbacks>vtbl) ( callbacks -- vtbl )
     [ execute ] void*-array{ } map-as underlying>> malloc-byte-array ;
@@ -159,5 +162,5 @@ M: com-wrapper dispose*
 
 : com-wrap ( object wrapper -- wrapped-object )
     [ vtbls>> ] [ (malloc-wrapped-object) ] bi
-    [ [ set-void*-nth ] curry each-index ] keep
+    [ over length <direct-void*-array> 0 swap copy ] keep
     [ +wrapped-objects+ get-global set-at ] keep ;

basis/windows/dinput/constants/constants.factor

@@ -1,7 +1,8 @@
 USING: windows.dinput windows.kernel32 windows.ole32 windows.com
 windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces
 combinators sequences symbols fry math accessors macros words quotations
-libc continuations generalizations splitting locals assocs init ;
+libc continuations generalizations splitting locals assocs init
+struct-arrays ;
 IN: windows.dinput.constants
 
 ! Some global variables aren't provided by the DirectInput DLL (they're in the
@@ -52,14 +53,14 @@ SYMBOLS:
     } cleave
     "DIOBJECTDATAFORMAT" <c-object> (DIOBJECTDATAFORMAT) ;
 
-: malloc-DIOBJECTDATAFORMAT-array ( struct array -- alien )
+:: malloc-DIOBJECTDATAFORMAT-array ( struct array -- alien )
-    [ nip length "DIOBJECTDATAFORMAT" malloc-array dup ]
+    [let | alien [ array length "DIOBJECTDATAFORMAT" malloc-struct-array ] |
-    [
+        array [| args i |
-        -rot [| args i alien struct |
             struct args <DIOBJECTDATAFORMAT>
-            i alien set-DIOBJECTDATAFORMAT-nth
+            i alien set-nth
-        ] 2curry each-index
+        ] each-index
-    ] 2bi ;
+        alien underlying>>
+    ] ;
 
 : (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien )
     [ {

core/classes/mixin/mixin.factor

@@ -25,7 +25,7 @@ M: mixin-class rank-class drop 3 ;
         bi
     ] if ;
 
-TUPLE: check-mixin-class mixin ;
+TUPLE: check-mixin-class class ;
 
 : check-mixin-class ( mixin -- mixin )
     dup mixin-class? [

extra/cfdg/cfdg.factor

@@ -6,8 +6,10 @@ USING: kernel alien.c-types combinators namespaces make arrays
        vars colors self self.slots
        random-weighted colors.hsv cfdg.gl accessors
        ui.gadgets.handler ui.gestures assocs ui.gadgets macros
-       qualified speicalized-arrays.double ;
+       qualified specialized-arrays.double ;
+
 QUALIFIED: syntax
+
 IN: cfdg
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -53,7 +55,10 @@ VAR: color-stack
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ;
+! : double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ;
+
+: double-nth* ( c-array indices -- seq )
+  swap byte-array>double-array [ nth ] curry map ;
 
 : check-size ( modelview -- num ) { 0 1 4 5 } double-nth* [ abs ] map biggest ;