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

basis/alien/c-types/c-types-docs.factor

@@ -105,12 +105,12 @@ HELP: unbox-return
 { $notes "This is an internal word used by the compiler when compiling callbacks." } ;
 
 HELP: define-deref
-{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
+{ $values { "name" "a word name" } }
 { $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." }
 { $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
 
 HELP: define-out
-{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
+{ $values { "name" "a word name" } }
 { $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
 { $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
 

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/debugger/debugger.factor

@@ -125,9 +125,13 @@ M: node node>quot drop ;
 : nodes>quot ( node -- quot )
     [ [ node>quot ] each ] [ ] make ;
 
-: optimized. ( quot/word -- )
+GENERIC: optimized. ( quot/word -- )
-    dup word? [ specialized-def ] when
+
-    build-tree optimize-tree nodes>quot . ;
+M: method-spec optimized. first2 method optimized. ;
+
+M: word optimized. specialized-def optimized. ;
+
+M: callable optimized. build-tree optimize-tree nodes>quot . ;
 
 SYMBOL: words-called
 SYMBOL: generics-called

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/inlining/inlining.factor

@@ -3,7 +3,7 @@
 USING: accessors kernel arrays sequences math math.order
 math.partial-dispatch generic generic.standard generic.math
 classes.algebra classes.union sets quotations assocs combinators
-words namespaces continuations
+words namespaces continuations classes fry
 compiler.tree
 compiler.tree.builder
 compiler.tree.recursive
@@ -26,7 +26,7 @@ GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
 M: word splicing-nodes
     [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
 
-M: quotation splicing-nodes
+M: callable splicing-nodes
     build-sub-tree analyze-recursive normalize ;
 
 : propagate-body ( #call -- )
@@ -140,18 +140,21 @@ SYMBOL: history
 : remember-inlining ( word -- )
     history [ swap suffix ] change ;
 
-: inline-word ( #call word -- ? )
+: inline-word-def ( #call word quot -- ? )
-    dup history get memq? [
+    over history get memq? [
-        2drop f
+        3drop f
     ] [
         [
-            dup remember-inlining
+            swap remember-inlining
-            dupd def>> splicing-nodes >>body
+            dupd splicing-nodes >>body
             propagate-body
         ] with-scope
         t
     ] if ;
 
+: inline-word ( #call word -- ? )
+    dup def>> inline-word-def ;
+
 : inline-method-body ( #call word -- ? )
     2dup should-inline? [ inline-word ] [ 2drop f ] if ;
 
@@ -165,6 +168,10 @@ SYMBOL: history
     [ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack
     first object swap eliminate-dispatch ;
 
+: inline-instance-check ( #call word -- ? )
+    over in-d>> second value-info literal>> dup class?
+    [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
+
 : do-inlining ( #call word -- ? )
     #! If the generic was defined in an outer compilation unit,
     #! then it doesn't have a definition yet; the definition
@@ -177,6 +184,7 @@ SYMBOL: history
     {
         { [ dup deferred? ] [ 2drop f ] }
         { [ dup custom-inlining? ] [ inline-custom ] }
+        { [ dup \ instance? eq? ] [ inline-instance-check ] }
         { [ dup always-inline-word? ] [ inline-word ] }
         { [ dup standard-generic? ] [ inline-standard-method ] }
         { [ dup math-generic? ] [ inline-math-method ] }

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>
-    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/mmap/mmap-docs.factor

@@ -17,7 +17,7 @@ HELP: <mapped-file>
 { $errors "Throws an error if a memory mapping could not be established." } ;
 
 HELP: with-mapped-file
-{ $values { "path" "a pathname string" } { "length" integer } { "quot" { $quotation "( mmap -- )" } } }
+{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
 { $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
 { $errors "Throws an error if a memory mapping could not be established." } ;
 

basis/io/mmap/ushort/ushort.factor

@@ -1,4 +1,4 @@
-USE: specialized-arrays.functor
+USING: io.mmap.functor specialized-arrays.direct.ushort ;
-IN: specialized-arrays.ushort
+IN: io.mmap.ushort
 
-<< "ushort" define-array >>
+<< "ushort" define-mapped-array >>

basis/io/windows/nt/monitors/monitors.factor

@@ -1,11 +1,12 @@
 ! Copyright (C) 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types libc destructors locals kernel math
+USING: alien alien.c-types alien.strings libc destructors locals
-assocs namespaces make continuations sequences hashtables
+kernel math assocs namespaces make continuations sequences
-sorting arrays combinators math.bitwise strings system accessors
+hashtables sorting arrays combinators math.bitwise strings
-threads splitting io.backend io.windows io.windows.nt.backend
+system accessors threads splitting io.backend io.windows
-io.windows.nt.files io.monitors io.ports io.buffers io.files
+io.windows.nt.backend io.windows.nt.files io.monitors io.ports
-io.timeouts io windows windows.kernel32 windows.types ;
+io.buffers io.files io.timeouts io.encodings.string io
+windows windows.kernel32 windows.types ;
 IN: io.windows.nt.monitors
 
 : open-directory ( path -- handle )

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/locals/locals.factor

@@ -346,7 +346,7 @@ SYMBOL: in-lambda?
 
 : (parse-wbindings) ( end -- )
     dup parse-binding dup [
-        first2 [ make-local-word ] dip 2array ,
+        first2 [ make-local-word ] keep 2array ,
         (parse-wbindings)
     ] [ 2drop ] if ;
 

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/nibble-arrays/nibble-arrays-tests.factor

@@ -0,0 +1,6 @@
+USING: nibble-arrays tools.test sequences kernel math ;
+IN: nibble-arrays.tests
+
+[ t ] [ 16 dup >nibble-array sequence= ] unit-test
+[ N{ 4 2 1 3 } ] [ N{ 3 1 2 4 } reverse ] unit-test
+[ N{ 1 4 9 0 9 4 } ] [ N{ 1 2 3 4 5 6 } [ sq ] map ] unit-test

basis/nibble-arrays/nibble-arrays.factor

@@ -17,10 +17,10 @@ TUPLE: nibble-array
 : byte/nibble ( n -- shift n' )
     [ 1 bitand 2 shift ] [ -1 shift ] bi ; inline
 
-: get-nibble ( shift n byte -- nibble )
+: get-nibble ( n byte -- nibble )
     swap neg shift nibble bitand ; inline
 
-: set-nibble ( value shift n byte -- byte' )
+: set-nibble ( value n byte -- byte' )
     nibble pick shift bitnot bitand -rot shift bitor ; inline
 
 : nibble@ ( n nibble-array -- shift n' byte-array )

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 [
+            pprint-word
             dup pprint-narrow? <inset
             >pprint-sequence pprint-elements
-        block> r> pprint-word block>
+            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/random/mersenne-twister/mersenne-twister.factor

@@ -2,48 +2,54 @@
 ! See http://factorcode.org/license.txt for BSD license.
 ! mersenne twister based on 
 ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
-USING: kernel math namespaces sequences system init
+USING: kernel math namespaces sequences sequences.private system
-accessors math.ranges random circular math.bitwise
+init accessors math.ranges random math.bitwise combinators
-combinators specialized-arrays.uint ;
+specialized-arrays.uint fry ;
 IN: random.mersenne-twister
 
 <PRIVATE
 
-TUPLE: mersenne-twister seq i ;
+TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
 
 : mt-n 624 ; inline
 : mt-m 397 ; inline
 : mt-a HEX: 9908b0df ; inline
 
+: wrap-nth ( n seq -- obj )
+    [ length mod ] keep nth-unsafe ; inline
+
+: set-wrap-nth ( obj n seq -- )
+    [ length mod ] keep set-nth-unsafe ; inline
+
 : calculate-y ( n seq -- y )
-    [ nth 31 mask-bit ]
+    [ wrap-nth 31 mask-bit ]
-    [ [ 1+ ] [ nth ] bi* 31 bits ] 2bi bitor ; inline
+    [ [ 1+ ] [ wrap-nth ] bi* 31 bits ] 2bi bitor ; inline
 
 : (mt-generate) ( n seq -- next-mt )
     [
         calculate-y
         [ 2/ ] [ odd? mt-a 0 ? ] bi bitxor
     ] [
-        [ mt-m + ] [ nth ] bi*
+        [ mt-m + ] [ wrap-nth ] bi*
-    ] 2bi bitxor ;
+    ] 2bi bitxor ; inline
 
 : mt-generate ( mt -- )
     [
-        mt-n swap seq>> [
+        mt-n swap seq>> '[
-            [ (mt-generate) ] [ set-nth ] 2bi
+            _ [ (mt-generate) ] [ set-wrap-nth ] 2bi
-        ] curry each
+        ] each
-    ] [ 0 >>i drop ] bi ;
+    ] [ 0 >>i drop ] bi ; inline
 
 : init-mt-formula ( i seq -- f(seq[i]) )
-    dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ;
+    dupd wrap-nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline
 
 : init-mt-rest ( seq -- )
-    mt-n 1- swap [
+    mt-n 1- swap '[
-        [ init-mt-formula ] [ [ 1+ ] dip set-nth ] 2bi
+        _ [ init-mt-formula ] [ [ 1+ ] dip set-wrap-nth ] 2bi
-    ] curry each ;
+    ] each ; inline
 
 : init-mt-seq ( seed -- seq )
-    32 bits mt-n <uint-array> <circular>
+    32 bits mt-n <uint-array>
     [ set-first ] [ init-mt-rest ] [ ] tri ;
 
 : mt-temper ( y -- yt )
@@ -53,7 +59,7 @@ TUPLE: mersenne-twister seq i ;
     dup -18 shift bitxor ; inline
 
 : next-index  ( mt -- i )
-    dup i>> dup mt-n < [ nip ] [ drop mt-generate 0 ] if ;
+    dup i>> dup mt-n < [ nip ] [ drop mt-generate 0 ] if ; inline
 
 PRIVATE>
 
@@ -66,7 +72,7 @@ M: mersenne-twister seed-random ( mt seed -- )
 
 M: mersenne-twister random-32* ( mt -- r )
     [ next-index ]
-    [ seq>> nth mt-temper ]
+    [ seq>> wrap-nth mt-temper ]
     [ [ 1+ ] change-i drop ] tri ;
 
 USE: init

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
-    r> [ collect ] keep ; inline
+    ] dip [ 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/specialized-arrays/direct/functor/functor.factor

@@ -20,7 +20,7 @@ SET-NTH [ T dup c-setter array-accessor ]
 WHERE
 
 TUPLE: A
-{ underlying simple-alien read-only }
+{ underlying alien read-only }
 { length fixnum read-only } ;
 
 : <A> ( alien len -- direct-array ) A boa ; inline

basis/specialized-arrays/double/double.factor

@@ -2,3 +2,69 @@ USE: specialized-arrays.functor
 IN: specialized-arrays.double
 
 << "double" define-array >>
+
+! Specializer hints. These should really be generalized, and placed
+! somewhere else
+USING: hints math.vectors arrays kernel math accessors sequences ;
+
+HINTS: <double-array> { 2 } { 3 } ;
+
+HINTS: vneg { array } { double-array } ;
+HINTS: v*n { array object } { double-array float } ;
+HINTS: n*v { array object } { float double-array } ;
+HINTS: v/n { array object } { double-array float } ;
+HINTS: n/v { object array } { float double-array } ;
+HINTS: v+ { array array } { double-array double-array } ;
+HINTS: v- { array array } { double-array double-array } ;
+HINTS: v* { array array } { double-array double-array } ;
+HINTS: v/ { array array } { double-array double-array } ;
+HINTS: vmax { array array } { double-array double-array } ;
+HINTS: vmin { array array } { double-array double-array } ;
+HINTS: v. { array array } { double-array double-array } ;
+HINTS: norm-sq { array } { double-array } ;
+HINTS: norm { array } { double-array } ;
+HINTS: normalize { array } { double-array } ;
+HINTS: distance { array array } { double-array double-array } ;
+
+! Type functions
+USING: words classes.algebra compiler.tree.propagation.info
+math.intervals ;
+
+{ v+ v- v* v/ vmax vmin } [
+    [
+        [ class>> double-array class<= ] both?
+        double-array object ? <class-info>
+    ] "outputs" set-word-prop
+] each
+
+{ n*v n/v } [
+    [
+        nip class>> double-array class<= double-array object ? <class-info>
+    ] "outputs" set-word-prop
+] each
+
+{ v*n v/n } [
+    [
+        drop class>> double-array class<= double-array object ? <class-info>
+    ] "outputs" set-word-prop
+] each
+
+{ vneg normalize } [
+    [
+        class>> double-array class<= double-array object ? <class-info>
+    ] "outputs" set-word-prop
+] each
+
+\ norm-sq [
+    class>> double-array class<= [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
+] "outputs" set-word-prop
+
+\ v. [
+    [ class>> double-array class<= ] both?
+    float object ? <class-info>
+] "outputs" set-word-prop
+
+\ distance [
+    [ class>> double-array class<= ] both?
+    [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
+] "outputs" set-word-prop

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 } { "struct-array" struct-array } }
+{ $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 } { "struct-array" struct-array } }
+{ $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/deploy/shaker/shaker.factor

@@ -109,6 +109,7 @@ IN: tools.deploy.shaker
                 "default-method"
                 "default-output-classes"
                 "derived-from"
+                "ebnf-parser"
                 "engines"
                 "forgotten"
                 "identities"
@@ -270,7 +271,7 @@ IN: tools.deploy.shaker
 
             { } { "math.partial-dispatch" } strip-vocab-globals %
 
-            "peg-cache" "peg" lookup ,
+            { } { "peg" } strip-vocab-globals %
         ] when
 
         strip-prettyprint? [
@@ -346,7 +347,7 @@ IN: tools.deploy.shaker
 
 : finish-deploy ( final-image -- )
     "Finishing up" show
-    >r { } set-datastack r>
+    [ { } set-datastack ] dip
     { } set-retainstack
     V{ } set-namestack
     V{ } set-catchstack
@@ -387,9 +388,9 @@ SYMBOL: deploy-vocab
     strip-c-io
     f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
     deploy-vocab get vocab-main set-boot-quot*
-    stripped-word-props >r
+    stripped-word-props
     stripped-globals strip-globals
-    r> strip-words
+    strip-words
     compress-byte-arrays
     compress-quotations
     compress-strings

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/syntax/syntax.factor

@@ -1,7 +1,7 @@
-USING: alien alien.c-types effects kernel windows.ole32
+USING: alien alien.c-types alien.accessors effects kernel
-parser lexer splitting grouping sequences namespaces
+windows.ole32 parser lexer splitting grouping sequences
-assocs quotations generalizations accessors words macros alien.syntax
+namespaces assocs quotations generalizations accessors words
-fry arrays ;
+macros alien.syntax fry arrays layouts math ;
 IN: windows.com.syntax
 
 <PRIVATE
@@ -10,9 +10,9 @@ C-STRUCT: com-interface
     { "void*" "vtbl" } ;
 
 MACRO: com-invoke ( n return parameters -- )
-    dup length -roll
+    [ 2nip length ] 3keep
     '[
-        _ npick com-interface-vtbl _ swap void*-nth _ _
+        _ npick com-interface-vtbl _ cell * alien-cell _ _
         "stdcall" alien-indirect
     ] ;
 

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 )
     [ {

basis/windows/ole32/ole32.factor

@@ -1,7 +1,7 @@
 USING: alien alien.syntax alien.c-types alien.strings math
 kernel sequences windows windows.types debugger io accessors
 math.order namespaces make math.parser windows.kernel32
-combinators ;
+combinators locals specialized-arrays.direct.uchar ;
 IN: windows.ole32
 
 LIBRARY: ole32
@@ -134,20 +134,22 @@ M: ole32-error error.
 : GUID-STRING-LENGTH
     "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
 
-: (guid-section>guid) ( guid string start end quot -- )
+:: (guid-section>guid) ( string guid start end quot -- )
-    [ roll subseq hex> swap ] dip call ; inline
+    start end string subseq hex> guid quot call ; inline
-: (guid-byte>guid) ( guid string start end byte -- )
+
-    [ roll subseq hex> ] dip
+:: (guid-byte>guid) ( string guid start end byte -- )
-    rot GUID-Data4 set-uchar-nth ; inline
+    start end string subseq hex> byte guid set-nth ; inline
 
 : string>guid ( string -- guid )
-    "GUID" <c-object> [ {
+    "GUID" <c-object> [
+        {
             [  1  9 [ set-GUID-Data1 ] (guid-section>guid) ]
-
             [ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ]
-
             [ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ]
+            [ ]
+        } 2cleave
 
+        GUID-Data4 8 <direct-uchar-array> {
             [ 20 22 0 (guid-byte>guid) ]
             [ 22 24 1 (guid-byte>guid) ]
 
@@ -157,19 +159,24 @@ M: ole32-error error.
             [ 31 33 5 (guid-byte>guid) ]
             [ 33 35 6 (guid-byte>guid) ]
             [ 35 37 7 (guid-byte>guid) ]
-    } 2cleave ] keep ;
+        } 2cleave
+    ] keep ;
 
 : (guid-section%) ( guid quot len -- )
     [ call >hex ] dip CHAR: 0 pad-left % ; inline
+
 : (guid-byte%) ( guid byte -- )
-    swap GUID-Data4 uchar-nth >hex 2
+    swap nth >hex 2 CHAR: 0 pad-left % ; inline
-    CHAR: 0 pad-left % ; inline
 
 : guid>string ( guid -- string )
-    [ "{" % {
+    [
+        "{" % {
             [ [ GUID-Data1 ] 8 (guid-section%) "-" % ]
             [ [ GUID-Data2 ] 4 (guid-section%) "-" % ]
             [ [ GUID-Data3 ] 4 (guid-section%) "-" % ]
+            [ ]
+        } cleave
+        GUID-Data4 8 <direct-uchar-array> {
             [ 0 (guid-byte%) ]
             [ 1 (guid-byte%) "-" % ]
             [ 2 (guid-byte%) ]
@@ -178,5 +185,6 @@ M: ole32-error error.
             [ 5 (guid-byte%) ]
             [ 6 (guid-byte%) ]
             [ 7 (guid-byte%) "}" % ]
-    } cleave ] "" make ;
+        } cleave
+    ] "" make ;
 

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/benchmark/benchmark.factor

@@ -22,7 +22,7 @@ IN: benchmark
         [
             [
                 [ [ 1array $vocab-link ] with-cell ]
-                [ 1000000 /f pprint-cell ] bi*
+                [ [ 1000000 /f pprint-cell ] [ "failed" write ] if* ] bi*
             ] with-row
         ] assoc-each
     ] tabular-output ;

extra/benchmark/dawes/dawes.factor

@@ -1,16 +1,16 @@
-USING: sequences hints kernel math specialized-arrays.int ;
+USING: sequences hints kernel math specialized-arrays.int fry ;
 IN: benchmark.dawes
 
 ! Phil Dawes's performance problem
 
-: count-ones ( byte-array -- n ) [ 1 = ] sigma ;
+: count-ones ( int-array -- n ) [ 1 = ] count ; inline
 
 HINTS: count-ones int-array ;
 
-: make-byte-array ( -- byte-array )
+: make-int-array ( -- int-array )
     120000 [ 255 bitand ] int-array{ } map-as ;
 
 : dawes-benchmark ( -- )
-    make-byte-array 200 swap [ count-ones ] curry replicate drop ;
+    make-int-array 200 swap '[ _ count-ones ] replicate drop ;
 
 MAIN: dawes-benchmark

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 ;