Merge branch 'master' into simd-cleanup

Makefile

@@ -58,6 +58,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm/math.o \
 	vm/nursery_collector.o \
 	vm/object_start_map.o \
+	vm/objects.o \
 	vm/primitives.o \
 	vm/profiler.o \
 	vm/quotations.o \

basis/compiler/tests/alien.factor

@@ -588,5 +588,4 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
 ! Regression: calling an undefined function would raise a protection fault
 FUNCTION: void this_does_not_exist ( ) ;
 
-[ this_does_not_exist ] [ { "kernel-error" 10 f f } = ] must-fail-with
-
+[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with

basis/compiler/tests/intrinsics.factor

@@ -21,7 +21,6 @@ IN: compiler.tests.intrinsics
 [ 2 1 3 ] [ 1 2 3 [ swapd ] compile-call ] unit-test
 [ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
 [ 3 ] [ 1 2 3 [ 2nip ] compile-call ] unit-test
-[ 2 1 2 ] [ 1 2 [ tuck ] compile-call ] unit-test
 [ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
 [ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
 [ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test

basis/compiler/tree/debugger/debugger.factor

@@ -51,7 +51,6 @@ MATCH-VARS: ?a ?b ?c ;
         { { { ?b ?a } { ?a ?b } } [ swap ] }
         { { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] }
         { { { ?a ?b } { ?a ?a ?b } } [ dupd ] }
-        { { { ?a ?b } { ?b ?a ?b } } [ tuck ] }
         { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
         { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
         { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }

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

@@ -27,14 +27,16 @@ IN: compiler.tree.propagation.recursive.tests
 ] unit-test
 
 [ t ] [
+    T{ interval f { -268435456 t } { 268435455 t } }
     T{ interval f { 1 t } { 268435455 t } }
-    T{ interval f { -268435456 t } { 268435455 t } } tuck
+    over
     integer generalize-counter-interval =
 ] unit-test
 
 [ t ] [
+    T{ interval f { -268435456 t } { 268435455 t } }
     T{ interval f { 1 t } { 268435455 t } }
-    T{ interval f { -268435456 t } { 268435455 t } } tuck
+    over
     fixnum generalize-counter-interval =
 ] unit-test
 

basis/compiler/tree/propagation/transforms/transforms.factor

@@ -3,7 +3,7 @@
 USING: kernel sequences words fry generic accessors
 classes.tuple classes classes.algebra definitions
 stack-checker.state quotations classes.tuple.private math
-math.partial-dispatch math.private math.intervals
+math.partial-dispatch math.private math.intervals sets.private
 math.floats.private math.integers.private layouts math.order
 vectors hashtables combinators effects generalizations assocs
 sets combinators.short-circuit sequences.private locals
@@ -290,3 +290,13 @@ CONSTANT: lookup-table-at-max 256
     ] [ drop f ] if ;
 
 \ at* [ at-quot ] 1 define-partial-eval
+
+: diff-quot ( seq -- quot: ( seq' -- seq'' ) )
+    tester '[ [ @ not ] filter ] ;
+
+\ diff [ diff-quot ] 1 define-partial-eval
+
+: intersect-quot ( seq -- quot: ( seq' -- seq'' ) )
+    tester '[ _ filter ] ;
+
+\ intersect [ intersect-quot ] 1 define-partial-eval

basis/compression/run-length/run-length.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators grouping kernel locals math
-math.matrices math.order multiline sequence-parser sequences
+math.matrices math.order multiline sequences.parser sequences
 tools.continuations ;
 IN: compression.run-length
 

basis/core-text/core-text-tests.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tools.test core-text core-text.fonts core-foundation
 core-foundation.dictionaries destructors arrays kernel generalizations
-math accessors core-foundation.utilities combinators hashtables colors
+locals math accessors core-foundation.utilities combinators hashtables colors
 colors.constants ;
 IN: core-text.tests
 
@@ -18,10 +18,11 @@ IN: core-text.tests
     ] with-destructors
 ] unit-test
 
-: test-typographic-bounds ( string font -- ? )
+:: test-typographic-bounds ( string font -- ? )
     [
-        test-font &CFRelease tuck COLOR: white <CTLine> &CFRelease
-        compute-line-metrics {
+        font test-font &CFRelease :> ctfont
+        string ctfont COLOR: white <CTLine> &CFRelease :> ctline
+        ctfont ctline compute-line-metrics {
             [ width>> float? ]
             [ ascent>> float? ]
             [ descent>> float? ]
@@ -33,4 +34,4 @@ IN: core-text.tests
 
 [ t ] [ "Hello world" "Chicago" test-typographic-bounds ] unit-test
 
-[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test
+[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test

basis/cpu/ppc/bootstrap.factor

@@ -329,14 +329,6 @@ CONSTANT: rs-reg 14
     3 ds-reg 4 STWU
 ] \ dupd define-sub-primitive
 
-[
-    3 ds-reg 0 LWZ
-    4 ds-reg -4 LWZ
-    3 ds-reg 4 STWU
-    4 ds-reg -4 STW
-    3 ds-reg -8 STW
-] \ tuck define-sub-primitive
-
 [
     3 ds-reg 0 LWZ
     4 ds-reg -4 LWZ

basis/cpu/x86/bootstrap.factor

@@ -335,15 +335,6 @@ big-endian off
     ds-reg [] temp0 MOV
 ] \ dupd define-sub-primitive
 
-[
-    temp0 ds-reg [] MOV
-    temp1 ds-reg -1 bootstrap-cells [+] MOV
-    ds-reg bootstrap-cell ADD
-    ds-reg [] temp0 MOV
-    ds-reg -1 bootstrap-cells [+] temp1 MOV
-    ds-reg -2 bootstrap-cells [+] temp0 MOV
-] \ tuck define-sub-primitive
-
 [
     temp0 ds-reg [] MOV
     temp1 ds-reg bootstrap-cell neg [+] MOV

basis/csv/csv-tests.factor

@@ -70,11 +70,12 @@ IN: csv.tests
 
 "can write csv too!"
 [ "foo1,bar1\nfoo2,bar2\n" ]
-[ { { "foo1" "bar1" } { "foo2" "bar2" } } <string-writer> tuck write-csv >string ] named-unit-test
+[ { { "foo1" "bar1" } { "foo2" "bar2" } } <string-writer> [ write-csv ] keep >string ] named-unit-test
+
 
 "escapes quotes commas and newlines when writing"
 [ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ]
-[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } <string-writer> tuck write-csv >string ] named-unit-test ! "
+[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } <string-writer> [ write-csv ] keep >string ] named-unit-test ! "
 
 [ { { "writing" "some" "csv" "tests" } } ]
 [

basis/db/sqlite/sqlite.factor

@@ -4,7 +4,7 @@ USING: alien arrays assocs classes compiler db hashtables
 io.files kernel math math.parser namespaces prettyprint fry
 sequences strings classes.tuple alien.c-types continuations
 db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
-math.intervals io nmake accessors vectors math.ranges random
+math.intervals io locals nmake accessors vectors math.ranges random
 math.bitwise db.queries destructors db.tuples.private interpolate
 io.streams.string make db.private sequences.deep
 db.errors.sqlite ;
@@ -85,12 +85,11 @@ M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
     nip [ key>> ] [ value>> ] [ type>> ] tri
     <sqlite-low-level-binding> ;
 
-M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
-    tuck
-    [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
-    rot set-slot-named
-    [ [ key>> ] [ type>> ] bi ] dip
-    swap <sqlite-low-level-binding> ;
+M:: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
+    generate-bind generator-singleton>> eval-generator :> obj
+    generate-bind slot-name>> :> name
+    obj name tuple set-slot-named
+    generate-bind key>> obj generate-bind type>> <sqlite-low-level-binding> ;
 
 M: sqlite-statement bind-tuple ( tuple statement -- )
     [

basis/debugger/debugger-docs.factor

@@ -129,9 +129,6 @@ HELP: c-string-error.
 HELP: ffi-error.
 { $error-description "Thrown by " { $link dlopen } " and " { $link dlsym } " if a problem occurs while loading a native library or looking up a symbol. See " { $link "alien" } "." } ;
 
-HELP: heap-scan-error.
-{ $error-description "Thrown if " { $link next-object } " is called outside of a " { $link begin-scan } "/" { $link end-scan } " pair." } ;
-
 HELP: undefined-symbol-error.
 { $error-description "Thrown if a previously-compiled " { $link alien-invoke } " call refers to a native library symbol which no longer exists." } ;
 

basis/debugger/debugger.factor

@@ -103,9 +103,6 @@ HOOK: signal-error. os ( obj -- )
 : ffi-error. ( obj -- )
     "FFI error" print drop ;
 
-: heap-scan-error. ( obj -- )
-    "Cannot do next-object outside begin/end-scan" print drop ;
-
 : undefined-symbol-error. ( obj -- )
     "The image refers to a library or symbol that was not found at load time"
     print drop ;
@@ -148,14 +145,13 @@ PREDICATE: vm-error < array
         { 6  [ array-size-error.       ] }
         { 7  [ c-string-error.         ] }
         { 8  [ ffi-error.              ] }
-        { 9  [ heap-scan-error.        ] }
-        { 10 [ undefined-symbol-error. ] }
-        { 11 [ datastack-underflow.    ] }
-        { 12 [ datastack-overflow.     ] }
-        { 13 [ retainstack-underflow.  ] }
-        { 14 [ retainstack-overflow.   ] }
-        { 15 [ memory-error.           ] }
-        { 16 [ fp-trap-error.          ] }
+        { 9  [ undefined-symbol-error. ] }
+        { 10 [ datastack-underflow.    ] }
+        { 11 [ datastack-overflow.     ] }
+        { 12 [ retainstack-underflow.  ] }
+        { 13 [ retainstack-overflow.   ] }
+        { 14 [ memory-error.           ] }
+        { 15 [ fp-trap-error.          ] }
     } ; inline
 
 M: vm-error summary drop "VM error" ;

basis/fry/fry-docs.factor

@@ -2,17 +2,20 @@ USING: help.markup help.syntax quotations kernel ;
 IN: fry
 
 HELP: _
-{ $description "Fry specifier. Inserts a literal value into the fried quotation." } ;
+{ $description "Fry specifier. Inserts a literal value into the fried quotation." }
+{ $examples "See " { $link "fry.examples" } "." } ;
 
 HELP: @
-{ $description "Fry specifier. Splices a quotation into the fried quotation." } ;
+{ $description "Fry specifier. Splices a quotation into the fried quotation." }
+{ $examples "See " { $link "fry.examples" } "." } ;
 
 HELP: fry
 { $values { "quot" quotation } { "quot'" quotation } }
 { $description "Outputs a quotation that when called, fries " { $snippet "quot" } " by taking values from the stack and substituting them in." }
 { $notes "This word is used to implement " { $link POSTPONE: '[ } "; the following two lines are equivalent:"
     { $code "[ X ] fry call" "'[ X ]" }
-} ;
+}
+{ $examples "See " { $link "fry.examples" } "." } ;
 
 HELP: '[
 { $syntax "'[ code... ]" }
@@ -59,7 +62,6 @@ $nl
     { { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
     { { $link curry } { $snippet ": curry '[ _ @ ] ;" } }
     { { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
-    { { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } }
 } ;
 
 ARTICLE: "fry.philosophy" "Fried quotation philosophy"

basis/fry/fry-tests.factor

@@ -1,18 +1,41 @@
+! (c)2009 Slava Pestov, Eduardo Cavazos, Joe Groff bsd license
 USING: fry tools.test math prettyprint kernel io arrays
 sequences eval accessors ;
 IN: fry.tests
 
+SYMBOLS: a b c d e f g h ;
+
+[ [ 1 ] ] [ 1 '[ _ ] ] unit-test
+[ [ 1 ] ] [ [ 1 ] '[ @ ] ] unit-test
+[ [ 1 2 ] ] [ [ 1 ] [ 2 ] '[ @ @ ] ] unit-test
+
+[ [ 1 2 a ] ] [ 1 2 '[ _ _ a ] ] unit-test
+[ [ 1 2 ] ] [ 1 2 '[ _ _ ] ] unit-test
+[ [ a 1 2 ] ] [ 1 2 '[ a _ _ ] ] unit-test
+[ [ 1 2 a ] ] [ [ 1 ] [ 2 ] '[ @ @ a ] ] unit-test
+[ [ 1 a 2 b ] ] [ 1 2 '[ _ a _ b ] ] unit-test
+[ [ 1 a 2 b ] ] [ 1 [ 2 ] '[ _ a @ b ] ] unit-test
+[ [ a 1 b ] ] [ 1 '[ a _ b ] ] unit-test
+
+[ [ a 1 b ] ] [ [ 1 ] '[ a @ b ] ] unit-test
+[ [ a 1 2 ] ] [ [ 1 ] [ 2 ] '[ a @ @ ] ] unit-test
+
+[ [ a [ 1 ] b ] ] [ 1 '[ a [ _ ] b ] ] unit-test
+[ [ a 1 b [ c 2 d ] e 3 f ] ] [ 1 2 3 '[ a _ b [ c _ d ] e _ f ] ] unit-test
+[ [ a 1 b [ c 2 d [ e 3 f ] ] g 4 h ] ] [ 1 2 3 4 '[ a _ b [ c _ d [ e _ f ] ] g _ h ] ] unit-test
+[ [ a 1 b [ [ c 2 d ] e 3 f ] g 4 h ] ] [ 1 2 3 4 '[ a _ b [ [ c _ d ] e _ f ] g _ h ] ] unit-test
+
 [ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test
 
 [ [ 1 3 + ] ] [ 1 3 '[ _ _ + ] ] unit-test
 
-[ [ 1 [ + ] call ] ] [ 1 [ + ] '[ _ @ ] ] unit-test
+[ [ 1 + ] ] [ 1 [ + ] '[ _ @ ] ] unit-test
 
-[ [ 1 [ + ] call . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test
+[ [ 1 + . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test
 
-[ [ [ + ] [ - ] [ call ] dip call ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
+[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
 
-[ [ "a" "b" [ write ] dip print ] ]
+[ [ "a" write "b" print ] ]
 [ "a" "b" '[ _ write _ print ] ] unit-test
 
 [ 1/2 ] [

basis/fry/fry.factor

@@ -1,7 +1,6 @@
-! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences combinators parser splitting math
-quotations arrays make words locals.backend summary sets ;
+! (c)2009 Slava Pestov, Eduardo Cavazos, Joe Groff bsd license
+USING: accessors combinators kernel locals.backend math parser
+quotations sequences sets splitting words ;
 IN: fry
 
 : _ ( -- * ) "Only valid inside a fry" throw ;
@@ -9,21 +8,10 @@ IN: fry
 
 ERROR: >r/r>-in-fry-error ;
 
+GENERIC: fry ( quot -- quot' )
+
 <PRIVATE
 
-: [ncurry] ( n -- quot )
-    {
-        { 0 [ [ ] ] }
-        { 1 [ [ curry ] ] }
-        { 2 [ [ 2curry ] ] }
-        { 3 [ [ 3curry ] ] }
-        [ \ curry <repetition> ]
-    } case ;
-
-M: >r/r>-in-fry-error summary
-    drop
-    "Explicit retain stack manipulation is not permitted in fried quotations" ;
-
 : check-fry ( quot -- quot )
     dup { load-local load-locals get-local drop-locals } intersect
     [ >r/r>-in-fry-error ] unless-empty ;
@@ -36,21 +24,119 @@ M: callable count-inputs [ count-inputs ] map-sum ;
 M: fry-specifier count-inputs drop 1 ;
 M: object count-inputs drop 0 ;
 
-GENERIC: deep-fry ( obj -- )
+MIXIN: fried
+PREDICATE: fried-callable < callable
+    count-inputs 0 > ;
+INSTANCE: fried-callable fried
 
-: shallow-fry ( quot -- quot' curry# )
-    check-fry
-    [ [ deep-fry ] each ] [ ] make
-    [ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
-    { _ } split [ spread>quot ] [ length 1 - ] bi ;
+: (ncurry) ( quot n -- quot )
+    {
+        { 0 [ ] }
+        { 1 [ \ curry  suffix! ] }
+        { 2 [ \ 2curry suffix! ] }
+        { 3 [ \ 3curry suffix! ] }
+        [ [ \ 3curry suffix! ] dip 3 - (ncurry) ]
+    } case ;
+
+: [ncurry] ( n -- quot )
+    [ V{ } clone ] dip (ncurry) >quotation ;
+
+: [ndip] ( quot n -- quot' )
+    {
+        { 0 [ ] }
+        { 1 [ \ dip  [ ] 2sequence ] }
+        { 2 [ \ 2dip [ ] 2sequence ] }
+        { 3 [ \ 3dip [ ] 2sequence ] }
+        [ [ \ 3dip [ ] 2sequence ] dip 3 - [ndip] ]
+    } case ;
+
+: (make-curry) ( tail quot -- quot' )
+    swap [ncurry] curry [ compose ] compose ;
+
+: make-compose ( consecutive quot -- consecutive quot' )
+    [
+        [ [ ] ]
+        [ [ncurry] ] if-zero
+    ] [
+        [ [ compose ] ]
+        [ [ compose compose ] curry ] if-empty
+    ] bi* compose
+    0 swap ;
+
+: make-curry ( consecutive quot -- consecutive' quot' )
+    [ 1 + ] dip
+    [ [ ] ] [ (make-curry) 0 swap ] if-empty ;
+
+: convert-curry ( consecutive quot -- consecutive' quot' )
+    [ [ ] make-curry ] [
+        dup first \ @ =
+        [ rest >quotation make-compose ]
+        [ >quotation make-curry ] if
+    ] if-empty ;
+
+: prune-curries ( seq -- seq' )
+    dup [ empty? not ] find 
+    [ [ 1 + tail ] dip but-last prefix ]
+    [ 2drop { } ] if* ;
+
+: convert-curries ( seq -- tail seq' )
+    unclip-slice [ 0 swap [ convert-curry ] map ] dip
+    [ prune-curries ]
+    [ >quotation 1quotation prefix ] if-empty ;
+
+: mark-composes ( quot -- quot' )
+    [ dup \ @ = [ drop [ _ @ ] ] [ 1quotation ] if ] map concat ; inline
+
+: shallow-fry ( quot -- quot' )
+    check-fry mark-composes
+    { _ } split convert-curries
+    [ [ [ ] ] [ [ ] (make-curry) but-last ] if-zero ]
+    [ spread>quot swap [ [ ] (make-curry) compose ] unless-zero ] if-empty ;
+
+DEFER: dredge-fry
+
+TUPLE: dredge-fry-state
+    { in-quot read-only }
+    { prequot read-only }
+    { quot read-only } ;
+
+: <dredge-fry> ( quot -- dredge-fry )
+    V{ } clone V{ } clone dredge-fry-state boa ; inline
+
+: in-quot-slices ( n i state -- head tail )
+    in-quot>>
+    [ <slice> ]
+    [ [ drop ] 2dip swap 1 + tail-slice ] 3bi ; inline
+
+: push-head-slice ( head state -- )
+    quot>> [ push-all ] [ \ _ swap push ] bi ; inline
+
+: push-subquot ( tail elt state -- )
+    [ fry swap >quotation count-inputs [ndip] ] dip prequot>> push-all ; inline
+
+: (dredge-fry-subquot) ( n state i elt -- )
+    rot {
+        [ nip in-quot-slices ] ! head tail i elt state
+        [ [ 2drop swap ] dip push-head-slice ]
+        [ [ drop ] 2dip push-subquot ]
+        [ [ 1 + ] [ drop ] [ ] tri* dredge-fry ]
+    } 3cleave ; inline recursive
+
+: (dredge-fry-simple) ( n state -- )
+    [ in-quot>> swap tail-slice ] [ quot>> ] bi push-all ; inline recursive
+
+: dredge-fry ( n dredge-fry -- )
+    2dup in-quot>> [ fried? ] find-from
+    [ (dredge-fry-subquot) ]
+    [ drop (dredge-fry-simple) ] if* ; inline recursive
 
 PRIVATE>
 
-: fry ( quot -- quot' ) shallow-fry [ncurry] swap prefix ;
-
-M: callable deep-fry
-    [ count-inputs \ _ <repetition> % ] [ fry % ] bi ;
-
-M: object deep-fry , ;
+M: callable fry ( quot -- quot' )
+    0 swap <dredge-fry>
+    [ dredge-fry ] [
+        [ prequot>> >quotation ]
+        [ quot>> >quotation shallow-fry ] bi append
+    ] bi ;
 
 SYNTAX: '[ parse-quotation fry append! ;

basis/game/input/input.factor

@@ -75,9 +75,8 @@ SYMBOLS:
     get-controllers [ product-id = ] with filter ;
 : find-controller-instance ( product-id instance-id -- controller/f )
     get-controllers [
-        tuck
         [ product-id  = ]
-        [ instance-id = ] 2bi* and
+        [ instance-id = ] bi-curry bi* and
     ] with with find nip ;
 
 TUPLE: keyboard-state keys ;

basis/generalizations/generalizations-docs.factor

@@ -212,7 +212,7 @@ HELP: nwith
 } ;
 
 HELP: napply
-{ $values { "n" integer } }
+{ $values { "quot" quotation } { "n" integer } }
 { $description "A generalization of " { $link bi@ } " and " { $link tri@ } " that can work for any stack depth."
 } 
 { $examples
@@ -332,18 +332,6 @@ HELP: nappend-as
 
 { nappend nappend-as } related-words
 
-HELP: ntuck
-{ $values
-     { "n" integer }
-}
-{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ;
-
-HELP: nspin
-{ $values
-    { "n" integer }
-}
-{ $description "A generalization of " { $link spin } " that can work for any stack depth. The top " { $snippet "n" } " items will be reversed in order." } ;
-
 ARTICLE: "sequence-generalizations" "Generalized sequence operations"
 { $subsections
     narray
@@ -363,8 +351,6 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
     -nrot
     nnip
     ndrop
-    ntuck
-    nspin
     mnswap
     nweave
 } ;

basis/generalizations/generalizations-tests.factor

@@ -26,8 +26,6 @@ IN: generalizations.tests
 { 0 } [ 0 1 2 3 4 4 ndrop ] unit-test
 [ [ 1 ] 5 ndip ] must-infer
 [ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test
-[ 5 nspin ] must-infer
-[ 1 5 4 3 2 ] [ 1 2 3 4 5 4 nspin ] unit-test
 
 [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
 [ 1 2 3 4 5 2 '[ drop drop drop drop drop _ ] 5 nkeep ] must-infer

basis/generalizations/generalizations.factor

@@ -71,9 +71,6 @@ MACRO: ndrop ( n -- )
 MACRO: nnip ( n -- )
     '[ [ _ ndrop ] dip ] ;
 
-MACRO: ntuck ( n -- )
-    2 + '[ dup _ -nrot ] ;
-
 MACRO: ndip ( n -- )
     [ [ dip ] curry ] n*quot [ call ] compose ;
 
@@ -112,8 +109,8 @@ MACRO: cleave* ( n -- )
     [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ] 
     if-zero ;
 
-MACRO: napply ( n -- )
-    [ [ drop ] ] dip [ '[ tuck _ 2dip call ] ] times ;
+: napply ( quot n -- )
+    [ dupn ] [ spread* ] bi ; inline
 
 : apply-curry ( ...a quot n -- )
     [ [curry] ] dip napply ; inline
@@ -139,6 +136,3 @@ MACRO: nbi-curry ( n -- )
 
 : nappend ( n -- seq ) narray concat ; inline
 
-MACRO: nspin ( n -- )
-    [ [ ] ] swap [ swap [ ] curry compose ] n*quot [ call ] 3append ;
-

basis/hints/hints-docs.factor

@@ -20,7 +20,7 @@ HELP: specialized-def
 { $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;
 
 HELP: HINTS:
-{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes or literals" } }
+{ $values { "defspec" "a word or method" } { "hints..." "a list of sequences of classes or literals" } }
 { $description "Defines specialization hints for a word or a method."
 $nl
 "Each sequence in the list will cause a specialized version of the word to be compiled. Classes are tested for using their predicate, and literals are tested using " { $link eq? } "." }
@@ -35,8 +35,8 @@ $nl
     "M: assoc count-occurrences"
     "    swap [ = nip ] curry assoc-filter assoc-size ;"
     ""
-    "HINTS: { sequence count-occurrences } { object array } ;"
-    "HINTS: { assoc count-occurrences } { object hashtable } ;"
+    "HINTS: M\ sequence count-occurrences { object array } ;"
+    "HINTS: M\ assoc count-occurrences { object hashtable } ;"
 }
 } ;
 

basis/images/jpeg/jpeg.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Marc Fauconneau.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays byte-arrays combinators
-grouping compression.huffman images
+grouping compression.huffman images fry
 images.processing io io.binary io.encodings.binary io.files
 io.streams.byte-array kernel locals math math.bitwise
 math.constants math.functions math.matrices math.order
@@ -232,7 +232,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
     block dup length>> sqrt >fixnum group flip
     dup matrix-dim coord-matrix flip
     [
-        [ first2 spin nth nth ]
+        [ '[ _ [ second ] [ first ] bi ] dip nth nth ]
         [ x,y v+ color-id jpeg-image draw-color ] bi
     ] with each^2 ;
 
@@ -295,7 +295,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
     binary [
         [
             { HEX: FF } read-until
-            read1 tuck HEX: 00 = and
+            read1 [ HEX: 00 = and ] keep swap
         ]
         [ drop ] produce
         swap >marker {  EOI } assert=

basis/images/png/png.factor

@@ -290,6 +290,14 @@ ERROR: invalid-color-type/bit-depth loading-png ;
 : validate-truecolor-alpha ( loading-png -- loading-png )
     { 8 16 } validate-bit-depth ;
 
+: pad-bitmap ( image -- image )
+    dup dim>> first 4 divisor? [
+        dup [ bytes-per-pixel ]
+        [ dim>> first * ]
+        [ dim>> first 4 mod ] tri
+        '[ _ group [ _ 0 <array> append ] map B{ } concat-as ] change-bitmap
+    ] unless ;
+
 : loading-png>bitmap ( loading-png -- bytes component-order )
     dup color-type>> {
         { greyscale [
@@ -315,7 +323,7 @@ ERROR: invalid-color-type/bit-depth loading-png ;
         [ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ]
         [ [ width>> ] [ height>> ] bi 2array >>dim ]
         [ png-component >>component-type ]
-    } cleave ;
+    } cleave pad-bitmap ;
 
 : load-png ( stream -- loading-png )
     [

basis/inverse/inverse.factor

@@ -141,7 +141,6 @@ MACRO: undo ( quot -- ) [undo] ;
 \ 2dup [ over =/fail over =/fail ] define-inverse
 \ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse
 \ pick [ [ pick ] dip =/fail ] define-inverse
-\ tuck [ swapd [ =/fail ] keep ] define-inverse
 
 \ bi@ 1 [ [undo] '[ _ bi@ ] ] define-pop-inverse
 \ tri@ 1 [ [undo] '[ _ tri@ ] ] define-pop-inverse

basis/io/backend/windows/nt/nt.factor

@@ -50,16 +50,17 @@ M: winnt add-completion ( win32-handle -- )
         } cond
     ] with-timeout ;
 
-:: wait-for-overlapped ( us -- bytes-transferred overlapped error? )
+:: wait-for-overlapped ( usec -- bytes-transferred overlapped error? )
     master-completion-port get-global
-    0 <int> [ ! bytes
-        f <void*> ! key
-        f <void*> [ ! overlapped
-            us [ 1000 /i ] [ INFINITE ] if* ! timeout
-            GetQueuedCompletionStatus zero?
-        ] keep
-        *void* dup [ OVERLAPPED memory>struct ] when
-    ] keep *int spin ;
+    0 <int> :> bytes
+    f <void*> :> key
+    f <void*> :> overlapped
+    usec [ 1000 /i ] [ INFINITE ] if* :> timeout
+    bytes key overlapped timeout GetQueuedCompletionStatus zero? :> error?
+
+    bytes *int
+    overlapped *void* dup [ OVERLAPPED memory>struct ] when
+    error? ;
 
 : resume-callback ( result overlapped -- )
     >c-ptr pending-overlapped get-global delete-at* drop resume-with ;

basis/io/buffers/buffers-tests.factor

@@ -8,7 +8,7 @@ strings accessors destructors ;
     [ length ] dip buffer-reset ;
 
 : string>buffer ( string -- buffer )
-    dup length <buffer> tuck buffer-set ;
+    dup length <buffer> [ buffer-set ] keep ;
 
 : buffer-read-all ( buffer -- byte-array )
     [ [ pos>> ] [ ptr>> ] bi <displaced-alien> ]

basis/io/files/info/windows/windows.factor

@@ -151,12 +151,16 @@ PRIVATE>
 M: winnt file-system-info ( path -- file-system-info )
     normalize-path root-directory (file-system-info) ;
 
-: volume>paths ( string -- array )
-    16384 <ushort-array> tuck dup length
-    0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
-        win32-error-string throw
+:: volume>paths ( string -- array )
+    16384 :> names-buf-length
+    names-buf-length <ushort-array> :> names
+    0 <uint> :> names-length
+
+    string names names-buf-length names-length GetVolumePathNamesForVolumeName :> ret
+    ret 0 = [
+        ret win32-error-string throw
     ] [
-        *uint "ushort" heap-size * head
+        names names-length *uint "ushort" heap-size * head
         utf16n alien>string CHAR: \0 split
     ] if ;
 
@@ -166,13 +170,16 @@ M: winnt file-system-info ( path -- file-system-info )
     FindFirstVolume dup win32-error=0/f
     [ utf16n alien>string ] dip ;
 
-: find-next-volume ( handle -- string/f )
-    MAX_PATH 1 + [ <ushort-array> tuck ] keep
-    FindNextVolume 0 = [
+:: find-next-volume ( handle -- string/f )
+    MAX_PATH 1 + :> buf-length
+    buf-length <ushort-array> :> buf
+
+    handle buf buf-length FindNextVolume :> ret
+    ret 0 = [
         GetLastError ERROR_NO_MORE_FILES =
         [ drop f ] [ win32-error-string throw ] if
     ] [
-        utf16n alien>string
+        buf utf16n alien>string
     ] if ;
 
 : find-volumes ( -- array )

basis/io/launcher/windows/windows.factor

@@ -132,7 +132,7 @@ M: windows run-process* ( process -- handle )
         current-directory get absolute-path cd
 
         dup make-CreateProcess-args
-        tuck fill-redirection
+        [ fill-redirection ] keep
         dup call-CreateProcess
         lpProcessInformation>>
     ] with-destructors ;

basis/lists/lazy/lazy-tests.factor

@@ -35,5 +35,7 @@ IN: lists.lazy.tests
 [ [ drop ] leach ] must-infer
 [ lnth ] must-infer
 
+[ { 1 2 3 } ] [ { 1 2 3 4 5 } >list [ 2 > ] luntil list>array ] unit-test
+
 [ ] [ "resource:license.txt" utf8 <file-reader> llines list>array drop ] unit-test
 [ ] [ "resource:license.txt" utf8 <file-reader> lcontents list>array drop ] unit-test

basis/lists/lazy/lazy.factor

@@ -111,14 +111,15 @@ C: <lazy-until> lazy-until
     over nil? [ drop ] [ <lazy-until> ] if ;
 
 M: lazy-until car ( lazy-until -- car )
-     cons>> car ;
+    cons>> car ;
 
 M: lazy-until cdr ( lazy-until -- cdr )
-     [ cons>> unswons ] keep quot>> tuck call( elt -- ? )
-     [ 2drop nil ] [ luntil ] if ;
+    [ [ cons>> cdr ] [ quot>> ] bi ]
+    [ [ cons>> car ] [ quot>> ] bi call( elt -- ? ) ] bi
+    [ 2drop nil ] [ luntil ] if ;
 
 M: lazy-until nil? ( lazy-until -- ? )
-     drop f ;
+    drop f ;
 
 TUPLE: lazy-while cons quot ;
 
@@ -128,13 +129,13 @@ C: <lazy-while> lazy-while
     over nil? [ drop ] [ <lazy-while> ] if ;
 
 M: lazy-while car ( lazy-while -- car )
-     cons>> car ;
+    cons>> car ;
 
 M: lazy-while cdr ( lazy-while -- cdr )
-     [ cons>> cdr ] keep quot>> lwhile ;
+    [ cons>> cdr ] keep quot>> lwhile ;
 
 M: lazy-while nil? ( lazy-while -- ? )
-     [ car ] keep quot>> call( elt -- ? ) not ;
+    [ car ] keep quot>> call( elt -- ? ) not ;
 
 TUPLE: lazy-filter cons quot ;
 

basis/locals/fry/fry.factor

@@ -1,18 +1,21 @@
 ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors fry fry.private generalizations kernel
-locals.types make sequences ;
+locals.types sequences ;
 IN: locals.fry
 
 ! Support for mixing locals with fry
 
 M: let count-inputs body>> count-inputs ;
-
 M: lambda count-inputs body>> count-inputs ;
 
-M: lambda deep-fry
-    clone [ shallow-fry swap ] change-body
-    [ [ vars>> length ] keep '[ _ _ mnswap @ ] , ] [ drop [ncurry] % ] 2bi ;
+M: lambda fry
+    clone [ [ count-inputs ] [ fry ] bi ] change-body
+    [ [ vars>> length ] keep '[ _ _ mnswap _ call ] ]
+    [ drop [ncurry] curry [ call ] compose ] 2bi ;
 
-M: let deep-fry
-    clone [ fry '[ @ call ] ] change-body , ;
+M: let fry
+    clone [ fry ] change-body ;
+
+INSTANCE: lambda fried
+INSTANCE: let    fried

basis/locals/macros/macros.factor

@@ -14,4 +14,4 @@ M: let expand-macros* expand-macros literal ;
 
 M: lambda condomize? drop t ;
 
-M: lambda condomize '[ @ ] ;
+M: lambda condomize [ call ] curry ;

basis/math/blas/vectors/vectors.factor

@@ -78,10 +78,10 @@ PRIVATE>
 : n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline
 : n*V ( alpha x -- alpha*x ) clone n*V! ; inline
 
-: V+ ( x y -- x+y )
-    1.0 -rot n*V+V ; inline
-: V- ( x y -- x-y )
-    -1.0 spin n*V+V ; inline
+:: V+ ( x y -- x+y )
+    1.0 x y n*V+V ; inline
+:: V- ( x y -- x-y )
+    -1.0 y x n*V+V ; inline
 
 : Vneg ( x -- -x )
     -1.0 swap n*V ; inline

basis/math/combinatorics/combinatorics.factor

@@ -96,9 +96,9 @@ C: <combo> combo
     initial-values [ over 0 > ] [ next-values ] produce
     [ 3drop ] dip ;
 
-: combination-indices ( m combo -- seq )
-    [ tuck dual-index combinadic ] keep
-    seq>> length 1 - swap [ - ] with map ;
+:: combination-indices ( m combo -- seq )
+    combo m combo dual-index combinadic
+    combo seq>> length 1 - swap [ - ] with map ;
 
 : apply-combination ( m combo -- seq )
     [ combination-indices ] keep seq>> nths ;

basis/math/intervals/intervals-tests.factor

@@ -79,7 +79,7 @@ IN: math.intervals.tests
 
 [ t ] [ 1 2 [a,b] dup empty-interval interval-union = ] unit-test
 
-[ t ] [ empty-interval 1 2 [a,b] tuck interval-union = ] unit-test
+[ t ] [ 1 2 [a,b] empty-interval over interval-union = ] unit-test
 
 [ t ] [
     0 1 (a,b) 0 1 [a,b] interval-union 0 1 [a,b] =
@@ -250,7 +250,7 @@ IN: math.intervals.tests
     dup full-interval eq? [
         drop 32 random-bits 31 2^ -
     ] [
-        dup to>> first over from>> first tuck - random +
+        [ ] [ from>> first ] [ to>> first ] tri over - random +
         2dup swap interval-contains? [
             nip
         ] [

basis/math/matrices/elimination/elimination.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.vectors math.matrices namespaces
-sequences ;
+USING: kernel locals math math.vectors math.matrices
+namespaces sequences ;
 IN: math.matrices.elimination
 
 SYMBOL: matrix
@@ -85,12 +85,11 @@ SYMBOL: matrix
         ] each
     ] with-matrix ;
 
-: basis-vector ( row col# -- )
-    [ clone ] dip
-    [ swap nth neg recip ] 2keep
-    [ 0 spin set-nth ] 2keep
-    [ n*v ] dip
-    matrix get set-nth ;
+:: basis-vector ( row col# -- )
+    row clone :> row'
+    col# row' nth neg recip :> a
+    0 col# row' set-nth
+    a row n*v col# matrix get set-nth ;
 
 : nullspace ( matrix -- seq )
     echelon reduced dup empty? [

basis/math/ratios/ratios-tests.factor

@@ -84,8 +84,8 @@ unit-test
 [ 1.0 ] [ 0.5 1/2 + ] unit-test
 [ 1.0 ] [ 1/2 0.5 + ] unit-test
 
-[ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test
-[ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test
+[ 1/134217728 ] [ -1 -134217728 >fixnum / ] unit-test
+[ 134217728 ] [ -134217728 >fixnum -1 / ] unit-test
 
 [ 5 ]
 [ "10/2" string>number ]

basis/math/statistics/statistics-docs.factor

@@ -98,6 +98,19 @@ HELP: histogram*
 }
 { $description "Takes an existing hashtable and uses " { $link histogram } " to continue counting the number of occurences of each element." } ;
 
+HELP: sorted-histogram
+{ $values
+    { "seq" sequence }
+    { "alist" "an array of key/value pairs" }
+}
+{ $description "Outputs a " { $link histogram } " of a sequence sorted by number of occurences from lowest to highest." }
+{ $examples
+    { $example "USING: prettyprint math.statistics ;"
+        """"abababbbbbbc" sorted-histogram ."""
+        "{ { 99 1 } { 97 3 } { 98 8 } }"
+    }
+} ;
+
 HELP: sequence>assoc
 { $values
     { "seq" sequence } { "quot" quotation } { "exemplar" "an exemplar assoc" }
@@ -145,6 +158,7 @@ ARTICLE: "histogram" "Computing histograms"
 { $subsections
     histogram
     histogram*
+    sorted-histogram
 }
 "Combinators for implementing histogram:"
 { $subsections

basis/math/statistics/statistics.factor

@@ -79,6 +79,9 @@ PRIVATE>
 : histogram ( seq -- hashtable )
     [ inc-at ] sequence>hashtable ;
 
+: sorted-histogram ( seq -- alist )
+    histogram >alist sort-values ;
+
 : collect-values ( seq quot: ( obj hashtable -- ) -- hash )
     '[ [ dup @ ] dip push-at ] sequence>hashtable ; inline
 

basis/persistent/hashtables/hashtables-tests.factor

@@ -1,6 +1,6 @@
 IN: persistent.hashtables.tests
 USING: persistent.hashtables persistent.assocs hashtables assocs
-tools.test kernel namespaces random math.ranges sequences fry ;
+tools.test kernel locals namespaces random math.ranges sequences fry ;
 
 [ t ] [ PH{ } assoc-empty? ] unit-test
 
@@ -86,7 +86,7 @@ M: hash-0-b hashcode* 2drop 0 ;
 : random-assocs ( n -- hash phash )
     [ random-string ] replicate
     [ H{ } clone [ '[ swap _ set-at ] each-index ] keep ]
-    [ PH{ } clone swap [ spin new-at ] each-index ]
+    [ PH{ } clone swap [| ph elt i | i elt ph new-at ] each-index ]
     bi ;
 
 : ok? ( assoc1 assoc2 -- ? )

basis/persistent/hashtables/hashtables.factor

@@ -1,7 +1,7 @@
 ! Based on Clojure's PersistentHashMap by Rich Hickey.
 
 USING: kernel math accessors assocs fry combinators parser
-prettyprint.custom make
+prettyprint.custom locals make
 persistent.assocs
 persistent.hashtables.nodes
 persistent.hashtables.nodes.empty
@@ -38,8 +38,8 @@ M: persistent-hash pluck-at
 
 M: persistent-hash >alist [ root>> >alist% ] { } make ;
 
-: >persistent-hash ( assoc -- phash )
-    T{ persistent-hash } swap [ spin new-at ] assoc-each ;
+:: >persistent-hash ( assoc -- phash )
+    T{ persistent-hash } assoc [| ph k v | v k ph new-at ] assoc-each ;
 
 M: persistent-hash equal?
     over persistent-hash? [ assoc= ] [ 2drop f ] if ;

basis/persistent/vectors/vectors.factor

@@ -58,7 +58,7 @@ M: persistent-vector nth-unsafe
     [ 2array ] [ drop level>> 1 + ] 2bi node boa ;
 
 : new-child ( new-child node -- node' expansion/f )
-    dup full? [ tuck level>> 1node ] [ node-add f ] if ;
+    dup full? [ [ level>> 1node ] keep swap ] [ node-add f ] if ;
 
 : new-last ( val seq -- seq' )
     [ length 1 - ] keep new-nth ;
@@ -70,7 +70,7 @@ M: persistent-vector nth-unsafe
     dup level>> 1 = [
         new-child
     ] [
-        tuck children>> last (ppush-new-tail)
+        [ nip ] 2keep children>> last (ppush-new-tail)
         [ swap new-child ] [ swap node-set-last f ] ?if
     ] if ;
 

basis/regexp/dfa/dfa.factor

@@ -25,7 +25,7 @@ IN: regexp.dfa
     ] unless ;
 
 : epsilon-table ( states nfa -- table )
-    [ H{ } clone tuck ] dip
+    [ [ H{ } clone ] dip over ] dip
     '[ _ _ t epsilon-loop ] each ;
 
 : find-epsilon-closure ( states nfa -- dfa-state )

basis/regexp/disambiguate/disambiguate.factor

@@ -44,12 +44,12 @@ TUPLE: parts in out ;
         [ _ meaningful-integers ] keep add-out
     ] map ;
 
-: class-partitions ( classes -- assoc )
-    [ integer? ] partition [
-        dup powerset-partition spin add-integers
-        [ [ partition>class ] keep 2array ] map
-        [ first ] filter
-    ] [ '[ _ singleton-partition ] map ] 2bi append ;
+:: class-partitions ( classes -- assoc )
+    classes [ integer? ] partition :> ( integers classes )
+    
+    classes powerset-partition classes integers add-integers
+    [ [ partition>class ] keep 2array ] map [ first ] filter
+    integers [ classes singleton-partition ] map append ;
 
 : new-transitions ( transitions -- assoc ) ! assoc is class, partition
     values [ keys ] gather

basis/regexp/minimize/minimize.factor

@@ -85,7 +85,7 @@ IN: regexp.minimize
     '[ _ delete-duplicates ] change-transitions ;
 
 : combine-state-transitions ( hash -- hash )
-    H{ } clone tuck '[
+    [ H{ } clone ] dip over '[
         _ [ 2array <or-class> ] change-at
     ] assoc-each [ swap ] assoc-map ;
 

basis/roman/roman-tests.factor

@@ -29,7 +29,7 @@ USING: arrays kernel math roman roman.private sequences tools.test ;
 [ 3444 ] [ 3444 >roman roman> ] unit-test
 [ 3999 ] [ 3999 >roman roman> ] unit-test
 [ 0 >roman ] must-fail
-[ 4000 >roman ] must-fail
+[ 40000 >roman ] must-fail
 [ "vi" ] [ "iii" "iii"  roman+ ] unit-test
 [ "viii" ] [ "x" "ii"  roman- ] unit-test
 [ "ix" ] [ "iii" "iii"  roman* ] unit-test

basis/roman/roman.factor

@@ -17,7 +17,7 @@ CONSTANT: roman-values
 ERROR: roman-range-error n ;
 
 : roman-range-check ( n -- n )
-    dup 1 3999 between? [ roman-range-error ] unless ;
+    dup 1 10000 between? [ roman-range-error ] unless ;
 
 : roman-digit-index ( ch -- n )
     1string roman-digits index ; inline

basis/sequences/parser/authors.txt

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

basis/sequences/parser/parser-tests.factor

@@ -1,6 +1,6 @@
-USING: tools.test sequence-parser unicode.categories kernel
+USING: tools.test sequences.parser unicode.categories kernel
 accessors ;
-IN: sequence-parser.tests
+IN: sequences.parser.tests
 
 [ "hello" ]
 [ "hello" [ take-rest ] parse-sequence ] unit-test

basis/sequences/parser/parser.factor

@@ -3,7 +3,7 @@
 USING: accessors circular combinators.short-circuit fry io
 kernel locals math math.order sequences sorting.functor
 sorting.slots unicode.categories ;
-IN: sequence-parser
+IN: sequences.parser
 
 TUPLE: sequence-parser sequence n ;
 

basis/shuffle/shuffle-docs.factor

@@ -1,5 +1,7 @@
 USING: help.markup help.syntax ;
 IN: shuffle
 
+HELP: spin  $complex-shuffle ;
 HELP: roll  $complex-shuffle ;
 HELP: -roll $complex-shuffle ;
+HELP: tuck  $complex-shuffle ;

basis/shuffle/shuffle.factor

@@ -22,6 +22,10 @@ MACRO: shuffle-effect ( effect -- )
 SYNTAX: shuffle(
     ")" parse-effect suffix! \ shuffle-effect suffix! ;
 
+: tuck ( x y -- y x y ) swap over ; inline deprecated
+
+: spin ( x y z -- z y x ) swap rot ; inline deprecated
+
 : roll ( x y z t -- y z t x ) [ rot ] dip swap ; inline deprecated
 
 : -roll ( x y z t -- t x y z ) swap [ -rot ] dip ; inline deprecated

basis/stack-checker/known-words/known-words.factor

@@ -43,7 +43,6 @@ IN: stack-checker.known-words
     { swapd (( x y z -- y x z       )) }
     { nip   (( x y   -- y           )) }
     { 2nip  (( x y z -- z           )) }
-    { tuck  (( x y   -- y x y       )) }
     { over  (( x y   -- x y x       )) }
     { pick  (( x y z -- x y z x     )) }
     { swap  (( x y   -- y x         )) }
@@ -623,11 +622,7 @@ M: bad-executable summary
 \ <array> { integer object } { array } define-primitive
 \ <array> make-flushable
 
-\ begin-scan { } { } define-primitive
-
-\ next-object { } { object } define-primitive
-
-\ end-scan { } { } define-primitive
+\ all-instances { } { array } define-primitive
 
 \ size { object } { fixnum } define-primitive
 \ size make-flushable
@@ -704,7 +699,7 @@ M: bad-executable summary
 \ lookup-method { object array } { word } define-primitive
 
 \ reset-dispatch-stats { } { } define-primitive
-\ dispatch-stats { } { array } define-primitive
+\ dispatch-stats { } { byte-array } define-primitive
 
 \ optimized? { word } { object } define-primitive
 

basis/stack-checker/stack-checker-tests.factor

@@ -319,7 +319,7 @@ FORGET: erg's-inference-bug
 [ [ bad-recursion-3 ] infer ] must-fail
 FORGET: bad-recursion-3
 
-: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive
+: bad-recursion-4 ( -- ) 4 [ dup call [ rot ] dip swap ] times ; inline recursive
 [ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail
 
 : bad-recursion-5 ( obj quot: ( -- ) -- ) dup call swap bad-recursion-5 ; inline recursive

basis/suffix-arrays/suffix-arrays.factor

@@ -22,8 +22,7 @@ IN: suffix-arrays
 
 : <funky-slice> ( from/f to/f seq -- slice )
     [
-        tuck
-        [ drop 0 or ] [ length or ] 2bi*
+        [ drop 0 or ] [ length or ] bi-curry bi*
         [ min ] keep
     ] keep <slice> ; inline
 

basis/tools/memory/memory-docs.factor

@@ -13,11 +13,8 @@ ARTICLE: "tools.memory" "Object memory tools"
     data-room
     code-room
 }
-"There are a pair of combinators, analogous to " { $link each } " and " { $link filter } ", which operate on the entire collection of objects in the object heap:"
-{ $subsections
-    each-object
-    instances
-}
+"A combinator to get objects from the heap:"
+{ $subsections instances }
 "You can check an object's the heap memory usage:"
 { $subsections size }
 "The garbage collector can be invoked manually:"

basis/tools/scaffold/scaffold.factor

@@ -98,7 +98,7 @@ M: bad-developer-name summary
     [ main-file-string ] dip utf8 set-file-contents ;
 
 : scaffold-main ( vocab-root vocab -- )
-    tuck ".factor" vocab-root/vocab/suffix>path scaffolding? [
+    [ ".factor" vocab-root/vocab/suffix>path ] keep swap scaffolding? [
         set-scaffold-main-file
     ] [
         2drop

basis/tools/time/time-tests.factor

@@ -0,0 +1,4 @@
+IN: tools.time.tests
+USING: tools.time tools.test compiler ;
+
+[ ] [ [ [ ] time ] compile-call ] unit-test

basis/ui/traverse/traverse.factor

@@ -20,8 +20,9 @@ TUPLE: node value children ;
         ] [
             [
                 [ children>> swap first head-slice % ]
-                [ tuck traverse-step traverse-to-path ]
-                2bi
+                [ nip ]
+                [ traverse-step traverse-to-path ]
+                2tri
             ] make-node
         ] if
     ] if ;
@@ -35,7 +36,9 @@ TUPLE: node value children ;
         ] [
             [
                 [ traverse-step traverse-from-path ]
-                [ tuck children>> swap first 1 + tail-slice % ] 2bi
+                [ nip ]
+                [ children>> swap first 1 + tail-slice % ]
+                2tri
             ] make-node
         ] if
     ] if ;

basis/unix/groups/groups.factor

@@ -23,7 +23,7 @@ GENERIC: group-struct ( obj -- group/f )
     gr_mem>> utf8 alien>strings ;
 
 : (group-struct) ( id -- group-struct id group-struct byte-array length void* )
-    \ unix:group <struct> tuck 4096
+    [ \ unix:group <struct> ] dip over 4096
     [ <byte-array> ] keep f <void*> ;
 
 : check-group-struct ( group-struct ptr -- group-struct/f )

basis/validators/validators.factor

@@ -9,7 +9,7 @@ IN: validators
     >lower "on" = ;
 
 : v-default ( str def -- str/def )
-    over empty? spin ? ;
+    [ nip empty? ] 2keep ? ;
 
 : v-required ( str -- str )
     dup empty? [ "required" throw ] when ;

basis/vm/vm.factor

@@ -3,7 +3,7 @@
 USING: classes.struct alien.c-types alien.syntax ;
 IN: vm
 
-TYPEDEF: intptr_t cell
+TYPEDEF: uintptr_t cell
 C-TYPE: context
 
 STRUCT: zone

basis/windows/com/com-tests.factor

@@ -44,8 +44,8 @@ C: <test-implementation> test-implementation
         [ >>x drop ] ! IInherited::setX
     } }
     { IUnrelated {
-        [ swap x>> + ] ! IUnrelated::xPlus
-        [ spin x>> * + ] ! IUnrelated::xMulAdd
+        [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus
+        [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrelated::xMulAdd
     } }
 } <com-wrapper>
 dup +test-wrapper+ set [

basis/windows/com/wrapper/wrapper-docs.factor

@@ -27,8 +27,8 @@ COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c}
         [ >>x drop ]     ! IInherited::setX
     } }
     { "IUnrelated" {
-        [ swap x>> + ]   ! IUnrelated::xPlus
-        [ spin x>> * + ] ! IUnrealted::xMulAdd
+        [ [ x>> ] [ + ] bi* ]   ! IUnrelated::xPlus
+        [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrealted::xMulAdd
     } }
 } <com-wrapper>""" } ;
 

basis/xmode/catalog/catalog.factor

@@ -110,7 +110,7 @@ ERROR: mutually-recursive-rulesets ruleset ;
     dup [ glob-matches? ] [ 2drop f ] if ;
 
 : suitable-mode? ( file-name first-line mode -- ? )
-    tuck first-line-glob>> ?glob-matches
+    [ nip ] 2keep first-line-glob>> ?glob-matches
     [ 2drop t ] [ file-name-glob>> ?glob-matches ] if ;
 
 : find-mode ( file-name first-line -- mode )

basis/xmode/marker/marker.factor

@@ -86,7 +86,7 @@ M: regexp text-matches?
     [ >string ] dip first-match dup [ to>> ] when ;
 
 : rule-start-matches? ( rule -- match-count/f )
-    dup start>> tuck swap can-match-here? [
+    [ start>> dup ] keep can-match-here? [
         rest-of-line swap text>> text-matches?
     ] [
         drop f
@@ -96,7 +96,7 @@ M: regexp text-matches?
     dup mark-following-rule? [
         dup start>> swap can-match-here? 0 and
     ] [
-        dup end>> tuck swap can-match-here? [
+        [ end>> dup ] keep can-match-here? [
             rest-of-line
             swap text>> context get end>> or
             text-matches?
@@ -170,7 +170,7 @@ M: seq-rule handle-rule-start
     ?end-rule
     mark-token
     add-remaining-token
-    tuck body-token>> next-token,
+    [ body-token>> next-token, ] keep
     delegate>> [ push-context ] when* ;
 
 UNION: abstract-span-rule span-rule eol-span-rule ;
@@ -179,7 +179,7 @@ M: abstract-span-rule handle-rule-start
     ?end-rule
     mark-token
     add-remaining-token
-    tuck rule-match-token* next-token,
+    [ rule-match-token* next-token, ] keep
     ! ... end subst ...
     dup context get (>>in-rule)
     delegate>> push-context ;
@@ -190,7 +190,7 @@ M: span-rule handle-rule-end
 M: mark-following-rule handle-rule-start
     ?end-rule
     mark-token add-remaining-token
-    tuck rule-match-token* next-token,
+    [ rule-match-token* next-token, ] keep
     f context get (>>end)
     context get (>>in-rule) ;
 

core/bootstrap/primitives.factor

@@ -340,7 +340,6 @@ tuple
     { "swapd" "kernel" (( x y z -- y x z )) }
     { "nip" "kernel" (( x y -- y )) }
     { "2nip" "kernel" (( x y z -- z )) }
-    { "tuck" "kernel" (( x y -- y x y )) }
     { "over" "kernel" (( x y -- x y x )) }
     { "pick" "kernel" (( x y z -- x y z x )) }
     { "swap" "kernel" (( x y -- y x )) }
@@ -473,9 +472,7 @@ tuple
     { "resize-array" "arrays" (( n array -- newarray )) }
     { "resize-string" "strings" (( n str -- newstr )) }
     { "<array>" "arrays" (( n elt -- array )) }
-    { "begin-scan" "memory" (( -- )) }
-    { "next-object" "memory" (( -- obj )) }
-    { "end-scan" "memory" (( -- )) }
+    { "all-instances" "memory" (( -- array )) }
     { "size" "memory" (( obj -- n )) }
     { "die" "kernel" (( -- )) }
     { "(fopen)" "io.streams.c" (( path mode -- alien )) }

core/bootstrap/stage1.factor

@@ -17,25 +17,19 @@ load-help? off
 ! Create a boot quotation for the target
 [
     [
-        ! Rehash hashtables, since bootstrap.image creates them
-        ! using the host image's hashing algorithms. We don't
-        ! use each-object here since the catch stack isn't yet
-        ! set up.
-        gc
-        begin-scan
-        [ hashtable? ] pusher [ (each-object) ] dip
-        end-scan
-        [ rehash ] each
+        ! Rehash hashtables first, since bootstrap.image creates
+        ! them using the host image's hashing algorithms.
+        [ hashtable? ] instances [ rehash ] each
         boot
     ] %
 
     "math.integers" require
     "math.floats" require
     "memory" require
-    
+
     "io.streams.c" require
     "vocabs.loader" require
-    
+
     "syntax" require
     "bootstrap.layouts" require
 

core/definitions/definitions-docs.factor

@@ -20,7 +20,7 @@ $nl
 { $see-also "see" } ;
 
 ARTICLE: "definition-checking" "Definition sanity checking"
-"When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } ". A warning message is printed if any other definitions still depend on the removed definitions."
+"When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } "."
 $nl
 "The parser also catches forward references when reloading source files. This is best illustrated with an example. Suppose we load a source file " { $snippet "a.factor" } ":"
 { $code

core/generic/single/single.factor

@@ -63,19 +63,18 @@ TUPLE: predicate-engine class methods ;
 
 C: <predicate-engine> predicate-engine
 
-: push-method ( method specializer atomic assoc -- )
+: push-method ( method class atomic assoc -- )
     dupd [
         [ ] [ H{ } clone <predicate-engine> ] ?if
         [ methods>> set-at ] keep
     ] change-at ;
 
-: flatten-method ( class method assoc -- )
-    [ [ flatten-class keys ] keep ] 2dip [
-        [ spin ] dip push-method
-    ] 3curry each ;
+: flatten-method ( method class assoc -- )
+    over flatten-class keys
+    [ swap push-method ] with with with each ;
 
 : flatten-methods ( assoc -- assoc' )
-    H{ } clone [ [ flatten-method ] curry assoc-each ] keep ;
+    H{ } clone [ [ swapd flatten-method ] curry assoc-each ] keep ;
 
 ! 2. Convert methods
 : split-methods ( assoc class -- first second )

core/kernel/kernel-docs.factor

@@ -21,12 +21,10 @@ HELP: 2over                          $shuffle ;
 HELP: pick  ( x y z -- x y z x )     $shuffle ;
 HELP: swap  ( x y -- y x )           $shuffle ;
 
-HELP: spin                     $complex-shuffle ;
 HELP: rot   ( x y z -- y z x ) $complex-shuffle ;
 HELP: -rot  ( x y z -- z x y ) $complex-shuffle ;
 HELP: dupd  ( x y -- x x y )   $complex-shuffle ;
 HELP: swapd ( x y z -- y x z ) $complex-shuffle ;
-HELP: tuck  ( x y -- y x y )   $complex-shuffle ;
 
 HELP: datastack ( -- ds )
 { $values { "ds" array } }
@@ -821,14 +819,12 @@ $nl
 "Duplicating stack elements deep in the stack:"
 { $subsections
     dupd
-    tuck
 }
 "Permuting stack elements deep in the stack:"
 { $subsections
     swapd
     rot
     -rot
-    spin
 } ;
 
 ARTICLE: "shuffle-words" "Shuffle words"

core/kernel/kernel-tests.factor

@@ -13,11 +13,11 @@ IN: kernel.tests
 [ ] [ 10000 [ [ -1 f <array> ] ignore-errors ] times ] unit-test
 
 ! Make sure we report the correct error on stack underflow
-[ clear drop ] [ { "kernel-error" 11 f f } = ] must-fail-with
+[ clear drop ] [ { "kernel-error" 10 f f } = ] must-fail-with
 
 [ ] [ :c ] unit-test
 
-[ 3 [ { } set-retainstack ] dip ] [ { "kernel-error" 13 f f } = ] must-fail-with
+[ 3 [ { } set-retainstack ] dip ] [ { "kernel-error" 12 f f } = ] must-fail-with
 
 [ ] [ :c ] unit-test
 
@@ -34,15 +34,15 @@ IN: kernel.tests
 [ t "no-compile" set-word-prop ] each
 >>
 
-[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with
+[ overflow-d ] [ { "kernel-error" 11 f f } = ] must-fail-with
 
 [ ] [ :c ] unit-test
 
-[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with
+[ overflow-d-alt ] [ { "kernel-error" 11 f f } = ] must-fail-with
 
 [ ] [ [ :c ] with-string-writer drop ] unit-test
 
-[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with
+[ overflow-r ] [ { "kernel-error" 13 f f } = ] must-fail-with
 
 [ ] [ :c ] unit-test
 

core/kernel/kernel.factor

@@ -8,8 +8,6 @@ DEFER: 2dip
 DEFER: 3dip
 
 ! Stack stuff
-: spin ( x y z -- z y x ) swap rot ; inline
-
 : 2over ( x y z -- x y z x y ) pick pick ; inline
 
 : clear ( -- ) { } set-datastack ;

core/math/integers/integers-docs.factor

@@ -4,7 +4,7 @@ IN: math.integers
 ARTICLE: "integers" "Integers"
 { $subsections integer }
 "Integers come in two varieties -- fixnums and bignums. Fixnums fit in a machine word and are faster to manipulate; if the result of a fixnum operation is too large to fit in a fixnum, the result is upgraded to a bignum. Here is an example where two fixnums are multiplied yielding a bignum:"
-{ $example "USE: classes" "134217728 class ." "fixnum" }
+{ $example "USE: classes" "67108864 class ." "fixnum" }
 { $example "USE: classes" "128 class ." "fixnum" }
 { $example "134217728 128 * ." "17179869184" }
 { $example "USE: classes" "1 128 shift class ." "bignum" }

core/math/integers/integers-tests.factor

@@ -23,8 +23,8 @@ IN: math.integers.tests
 
 [ -1 ] [ 1 neg ] unit-test
 [ -1 ] [ 1 >bignum neg ] unit-test
-[ 268435456 ] [ -268435456 >fixnum -1 * ] unit-test
-[ 268435456 ] [ -268435456 >fixnum neg ] unit-test
+[ 134217728 ] [ -134217728 >fixnum -1 * ] unit-test
+[ 134217728 ] [ -134217728 >fixnum neg ] unit-test
 
 [ 9 3 ] [ 93 10 /mod ] unit-test
 [ 9 3 ] [ 93 >bignum 10 /mod ] unit-test
@@ -100,12 +100,12 @@ unit-test
 [ 16 ] [ 13 next-power-of-2 ] unit-test
 [ 16 ] [ 16 next-power-of-2 ] unit-test
 
-[ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test
-[ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test
-[ 0 ] [ -1 -268435456 >fixnum /i ] unit-test
+[ 134217728 ] [ -134217728 >fixnum -1 /i ] unit-test
+[ 134217728 0 ] [ -134217728 >fixnum -1 /mod ] unit-test
+[ 0 ] [ -1 -134217728 >fixnum /i ] unit-test
 [ 4420880996869850977 ] [ 13262642990609552931 3 /i ] unit-test
-[ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test
-[ 0 -1 ] [ -1 -268435456 >bignum /mod ] unit-test
+[ 0 -1 ] [ -1 -134217728 >fixnum /mod ] unit-test
+[ 0 -1 ] [ -1 -134217728 >bignum /mod ] unit-test
 [ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test
 [ 8 530505719624382123 ] [ 13262642990609552931 1591517158873146351 /mod ] unit-test
 [ 8 ] [ 13262642990609552931 1591517158873146351 /i ] unit-test
@@ -117,7 +117,7 @@ unit-test
 [ f ] [ 30 zero? ] unit-test
 [ t ] [ 0 >bignum zero? ] unit-test
 
-[ 4294967280 ] [ 268435455 >fixnum 16 fixnum* ] unit-test
+[ 2147483632 ] [ 134217727 >fixnum 16 fixnum* ] unit-test
 
 [ 23603949310011464311086123800853779733506160743636399259558684142844552151041 ]
 [
@@ -156,7 +156,7 @@ unit-test
 [ 4294967296 ] [ 1 32 shift ] unit-test
 [ 1267650600228229401496703205376 ] [ 1 100 shift ] unit-test
 
-[ t ] [ 1 27 shift fixnum? ] unit-test
+[ t ] [ 1 26 shift fixnum? ] unit-test
 
 [ t ] [
     t

core/memory/memory-docs.factor

@@ -2,42 +2,20 @@ USING: help.markup help.syntax debugger sequences kernel
 quotations math ;
 IN: memory
 
-HELP: begin-scan ( -- )
-{ $description "Disables the garbage collector and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects."
-$nl
-"This word must always be paired with a call to " { $link end-scan } "." }
-{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ;
-
-HELP: next-object ( -- obj )
-{ $values { "obj" object } }
-{ $description "Outputs the object at the heap scan pointer, and then advances the heap scan pointer. If the end of the heap has been reached, outputs " { $link f } ". This is unambiguous since the " { $link f } " object is tagged immediate and not actually stored in the heap." }
-{ $errors "Throws a " { $link heap-scan-error. } " if called outside a " { $link begin-scan } "/" { $link end-scan } " pair." }
-{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ;
-
-HELP: end-scan ( -- )
-{ $description "Finishes a heap iteration by re-enabling the garbage collector. This word must always be paired with a call to " { $link begin-scan } "." }
-{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ;
-
-HELP: each-object
-{ $values { "quot" { $quotation "( obj -- )" } } }
-{ $description "Applies a quotation to each object in the heap. The garbage collector is switched off while this combinator runs, so the given quotation must not allocate too much memory." }
-{ $notes "This word is the low-level facility used to implement the " { $link instances } " word." } ;
-
 HELP: instances
 { $values { "quot" { $quotation "( obj -- ? )" } } { "seq" "a fresh sequence" } }
-{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." }
-{ $notes "This word relies on " { $link each-object } ", so in particular the garbage collector is switched off while it runs and the given quotation must not allocate too much memory." } ;
+{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." } ;
 
 HELP: gc ( -- )
 { $description "Performs a full garbage collection." } ;
 
-HELP: data-room ( -- cards decks generations )
-{ $values { "cards" "number of kilobytes reserved for card marking" } { "decks" "number of kilobytes reserved for decks of cards" } { "generations" "array of free/total kilobytes pairs" } }
-{ $description "Queries the runtime for memory usage information." } ;
+HELP: data-room ( -- data-room )
+{ $values { "data-room" data-room } }
+{ $description "Queries the VM for memory usage information." } ;
 
-HELP: code-room ( -- code-total code-used code-free largest-free-block )
-{ $values { "code-total" "total kilobytes in the code heap" } { "code-used" "kilobytes used in the code heap" } { "code-free" "kilobytes free in the code heap" } { "largest-free-block" "size of largest free block" } }
-{ $description "Queries the runtime for memory usage information." } ;
+HELP: code-room ( -- code-room )
+{ $values { "code-room" code-room } }
+{ $description "Queries the VM for memory usage information." } ;
 
 HELP: size ( obj -- n )
 { $values { "obj" "an object" } { "n" "a size in bytes" } }
@@ -56,17 +34,6 @@ HELP: save-image-and-exit ( path -- )
 HELP: save
 { $description "Saves a snapshot of the heap to the current image file." } ;
 
-HELP: count-instances
-{ $values
-     { "quot" quotation }
-     { "n" integer } }
-{ $description "Applies the predicate quotation to each object in the heap and returns the number of objects that match. Since this word uses " { $link each-object } " with the garbage collector switched off, avoid allocating too much memory in the quotation." }
-{ $examples { $unchecked-example
-    "USING: memory words prettyprint ;"
-    "[ word? ] count-instances ."
-    "24210"
-} } ;
-
 ARTICLE: "images" "Images"
 "Factor has the ability to save the entire state of the system into an " { $emphasis "image file" } ". The image contains a complete dump of all data and code in the current Factor instance."
 { $subsections

core/memory/memory.factor

@@ -1,26 +1,11 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations sequences vectors arrays system math
+USING: kernel continuations sequences system
 io.backend alien.strings memory.private ;
 IN: memory
 
-: (each-object) ( quot: ( obj -- ) -- )
-    next-object dup [
-        swap [ call ] keep (each-object)
-    ] [ 2drop ] if ; inline recursive
-
-: each-object ( quot -- )
-    gc begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline
-
-: count-instances ( quot -- n )
-    0 swap [ 1 0 ? + ] compose each-object ; inline
-
 : instances ( quot -- seq )
-    #! To ensure we don't need to grow the vector while scanning
-    #! the heap, we do two scans, the first one just counts the
-    #! number of objects that satisfy the predicate.
-    [ count-instances 100 + <vector> ] keep swap
-    [ [ push-if ] 2curry each-object ] keep >array ; inline
+    [ all-instances ] dip filter ; inline
 
 : save-image ( path -- )
     normalize-path native-string>alien (save-image) ;

core/parser/parser-docs.factor

@@ -216,7 +216,7 @@ HELP: filter-moved
 { $description "Removes all definitions from " { $snippet "assoc2" } " which are in " { $snippet "assoc1" } " or are are no longer present in the current " { $link file } "." } ;
 
 HELP: forget-smudged
-{ $description "Forgets removed definitions and prints a warning message if any of them are still referenced from other source files." } ;
+{ $description "Forgets removed definitions." } ;
 
 HELP: finish-parsing
 { $values { "lines" "the lines of text just parsed" } { "quot" "the quotation just parsed" } }

core/splitting/splitting-docs.factor

@@ -13,6 +13,7 @@ ARTICLE: "sequences-split" "Splitting sequences"
     split1-last
     split1-last-slice
     split
+    split-when
 }
 "Splitting a string into lines:"
 { $subsections string-lines } ;
@@ -37,9 +38,14 @@ HELP: split1-last-slice
 
 { split1 split1-slice split1-last split1-last-slice } related-words
 
+HELP: split-when
+{ $values { "seq" "a sequence" } { "quot" { $quotation "( elt -- ? )" } } { "pieces" "a new array" } }
+{ $description "Splits " { $snippet "seq" } " at each occurrence of an element for which " { $snippet "quot" } " gives a true output and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." }
+{ $examples { $example "USING: ascii kernel prettyprint splitting ;" "\"hello,world-how.are:you\" [ letter? not ] split-when ." "{ \"hello\" \"world\" \"how\" \"are\" \"you\" }" } } ;
+
 HELP: split
 { $values { "seq" "a sequence" } { "separators" "a sequence" } { "pieces" "a new array" } }
-{ $description "Splits " { $snippet "seq" } " at each occurrence of an element of " { $snippet "separators" } ", and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." }
+{ $description "Splits " { $snippet "seq" } " at each occurrence of an element of " { $snippet "separators" } " and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." }
 { $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ;
 
 HELP: ?head

core/splitting/splitting-tests.factor

@@ -1,4 +1,4 @@
-USING: splitting tools.test kernel sequences arrays strings ;
+USING: splitting tools.test kernel sequences arrays strings ascii ;
 IN: splitting.tests
 
 [ "hello" "world ." ] [ "hello world ." " " split1 ] unit-test
@@ -57,3 +57,6 @@ unit-test
 [ { "hello" "hi" } ] [ "hello\nhi" string-lines ] unit-test
 [ { "hello" "hi" } ] [ "hello\rhi" string-lines ] unit-test
 [ { "hello" "hi" } ] [ "hello\r\nhi" string-lines ] unit-test
+
+[ { "hey" "world" "what's" "happening" } ]
+[ "heyAworldBwhat'sChappening" [ LETTER? ] split-when ] unit-test

core/splitting/splitting.factor

@@ -55,17 +55,21 @@ PRIVATE>
 
 <PRIVATE
 
-: (split) ( separators n seq -- )
-    3dup rot [ member? ] curry find-from drop
-    [ [ swap subseq , ] 2keep 1 + swap (split) ]
-    [ swap [ tail ] unless-zero , drop ] if* ; inline recursive
+: (split) ( n seq quot: ( elt -- ? ) -- )
+    [ find-from drop ]
+    [ [ [ 3dup swapd subseq , ] dip [ drop 1 + ] 2dip (split) ] 3curry ]
+    [ drop [ swap [ tail ] unless-zero , ] 2curry ]
+    3tri if* ; inline recursive
 
-: split, ( seq separators -- ) 0 rot (split) ;
+: split, ( seq quot -- ) [ 0 ] 2dip (split) ; inline
 
 PRIVATE>
 
 : split ( seq separators -- pieces )
-    [ split, ] { } make ;
+    [ [ member? ] curry split, ] { } make ;
+
+: split-when ( seq quot -- pieces )
+    [ split, ] { } make ; inline
 
 GENERIC: string-lines ( str -- seq )
 

extra/bank/bank.factor

@@ -63,7 +63,7 @@ C: <transaction> transaction
 
 : process-to-date ( account date -- account )
     over interest-last-paid>> 1 days time+
-    [ dupd process-day ] spin each-day ;
+    [ [ dupd process-day ] ] 2dip swap each-day ;
 
 : inserting-transactions ( account transactions -- account )
     [ [ date>> process-to-date ] keep >>transaction ] each ;

extra/benchmark/knucleotide/knucleotide.factor

@@ -1,4 +1,4 @@
-USING: kernel io io.files splitting strings io.encodings.ascii
+USING: kernel locals io io.files splitting strings io.encodings.ascii
        hashtables sequences assocs math namespaces prettyprint
        math.parser combinators arrays sorting unicode.case ;
 
@@ -21,10 +21,7 @@ IN: benchmark.knucleotide
     CHAR: \n swap remove >upper ;
 
 : tally ( x exemplar -- b )
-    clone tuck
-    [
-      [ [ 1 + ] [ 1 ] if* ] change-at
-    ] curry each ;
+    clone [ [ inc-at ] curry each ] keep ;
 
 : small-groups ( x n -- b )
     swap
@@ -42,10 +39,10 @@ IN: benchmark.knucleotide
     ] each
     drop ;
 
-: handle-n ( inputs x -- )
-    tuck length
-    small-groups H{ } tally
-    at [ 0 ] unless*
+:: handle-n ( inputs x -- )
+    inputs x length small-groups :> groups
+    groups H{ } tally :> b
+    x b at [ 0 ] unless*
     number>string 8 CHAR: \s pad-tail write ;
 
 : process-input ( input -- )

extra/c/lexer/lexer-tests.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors c.lexer kernel sequence-parser tools.test ;
+USING: accessors c.lexer kernel sequences.parser tools.test ;
 IN: c.lexer.tests
 
 [ 36 ]

extra/c/lexer/lexer.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators combinators.short-circuit
 generalizations kernel locals math.order math.ranges
-sequence-parser sequences sorting.functor sorting.slots
+sequences.parser sequences sorting.functor sorting.slots
 unicode.categories ;
 IN: c.lexer
 

extra/c/preprocessor/preprocessor.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: sequence-parser io io.encodings.utf8 io.files
+USING: sequences.parser io io.encodings.utf8 io.files
 io.streams.string kernel combinators accessors io.pathnames
 fry sequences arrays locals namespaces io.directories
 assocs math splitting make unicode.categories
@@ -93,11 +93,11 @@ ERROR: header-file-missing path ;
     skip-whitespace/comments
     [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
 
-: handle-define ( preprocessor-state sequence-parser -- )
-    [ take-define-identifier ]
-    [ skip-whitespace/comments take-rest ] bi 
-    "\\" ?tail [ readlns append ] when
-    spin symbol-table>> set-at ;
+:: handle-define ( preprocessor-state sequence-parser -- )
+    sequence-parser take-define-identifier :> ident
+    sequence-parser skip-whitespace/comments take-rest :> def
+    def "\\" ?tail [ readlns append ] when :> def
+    def ident preprocessor-state symbol-table>> set-at ;
 
 : handle-undef ( preprocessor-state sequence-parser -- )
     take-token swap symbol-table>> delete-at ;

extra/couchdb/couchdb.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs continuations debugger hashtables http
 http.client io io.encodings.string io.encodings.utf8 json.reader
-json.writer kernel make math math.parser namespaces sequences strings
-urls urls.encoding vectors ;
+json.writer kernel locals make math math.parser namespaces sequences
+strings urls urls.encoding vectors ;
 IN: couchdb
 
 ! NOTE: This code only works with the latest couchdb (0.9.*), because old
@@ -136,8 +136,9 @@ C: <db> db
 : attachments> ( assoc -- attachments ) "_attachments" swap at ;
 : >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ;
 
-: copy-key ( to from to-key from-key -- )
-    rot at spin set-at ;
+:: copy-key ( to from to-key from-key -- )
+    from-key from at
+    to-key to set-at ;
 
 : copy-id ( to from -- )
     "_id" "id" copy-key ;

extra/curses/curses.factor

@@ -123,8 +123,10 @@ PRIVATE>
 : curses-writef ( window string -- )
     [ window-ptr dup ] dip (curses-wprint) (curses-window-refresh) ;
 
-: (curses-read) ( window-ptr n encoding -- string )
-    [ [ <byte-array> tuck ] keep wgetnstr curses-error ] dip alien>string ;
+:: (curses-read) ( window-ptr n encoding -- string )
+    n <byte-array> :> buf
+    window-ptr buf n wgetnstr curses-error
+    buf encoding alien>string ;
 
 : curses-read ( window n -- string )
     utf8 [ window-ptr ] 2dip (curses-read) ;

extra/decimals/decimals.factor

@@ -37,7 +37,7 @@ SYNTAX: D: parse-decimal suffix! ;
     ] 2bi ;
 
 : scale-decimals ( D1 D2 -- D1' D2' )
-    scale-mantissas tuck [ <decimal> ] 2dip <decimal> ;
+    scale-mantissas [ <decimal> ] curry bi@ ;
 
 ERROR: decimal-types-expected d1 d2 ;
 

extra/digraphs/digraphs.factor

@@ -44,7 +44,7 @@ DEFER: (topological-sort)
     ] if ;
 
 : topological-sort ( digraph -- seq )
-    dup clone V{ } clone spin
+    [ V{ } clone ] dip [ clone ] keep
     [ drop (topological-sort) ] assoc-each drop reverse ;
 
 : topological-sorted-values ( digraph -- seq )

extra/ecdsa/ecdsa.factor

@@ -50,7 +50,7 @@ PRIVATE>
 
 : get-private-key ( -- bin/f )
     ec-key-handle EC_KEY_get0_private_key
-    dup [ dup BN_num_bits bits>bytes <byte-array> tuck BN_bn2bin drop ] when ;
+    dup [ dup BN_num_bits bits>bytes <byte-array> [ BN_bn2bin drop ] keep ] when ;
 
 :: get-public-key ( -- bin/f )
     ec-key-handle :> KEY

extra/fries/fries.factor

@@ -1,11 +1,15 @@
 USING: arrays vectors combinators effects kernel math sequences splitting
 strings.parser parser fry sequences.extras ;
+
+! a b c glue => acb
+! c b a [ append ] dip prepend
+
 IN: fries
 : str-fry ( str on -- quot ) split
-    [ unclip-last [ [ spin glue ] reduce-r ] 2curry ]
+    [ unclip-last [ [ [ append ] [ prepend ] bi* ] reduce-r ] 2curry ]
     [ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
 : gen-fry ( str on -- quot ) split
-    [ unclip-last [ [ spin 1array glue ] reduce-r ] 2curry ]
+    [ unclip-last [ [ [ 1array ] [ append ] [ prepend ] tri* ] reduce-r ] 2curry ]
     [ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
 
 SYNTAX: i" parse-string rest "_" str-fry append! ;

extra/gpu/framebuffers/framebuffers.factor

@@ -157,10 +157,13 @@ M: renderbuffer framebuffer-attachment-dim
     [ swap depth-attachment>>   [ swap call ] [ drop ] if* ]
     [ swap stencil-attachment>> [ swap call ] [ drop ] if* ] 2tri ; inline
 
-: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- )
-    [ [ color-attachments>> ] dip [ GL_COLOR_ATTACHMENT0 + swap ] prepose each-index ]
-    [ swap depth-attachment>>   [ GL_DEPTH_ATTACHMENT   spin call ] [ drop ] if* ]
-    [ swap stencil-attachment>> [ GL_STENCIL_ATTACHMENT spin call ] [ drop ] if* ] 2tri ; inline
+:: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- )
+    framebuffer color-attachments>>
+    [| attachment n | n GL_COLOR_ATTACHMENT0 + attachment quot call ] each-index
+    framebuffer depth-attachment>>
+    [| attachment | GL_DEPTH_ATTACHMENT attachment quot call ] when*
+    framebuffer stencil-attachment>>
+    [| attachment | GL_STENCIL_ATTACHMENT attachment quot call ] when* ; inline
 
 GENERIC: bind-framebuffer-attachment ( attachment-target attachment -- )
 

extra/html/parser/parser.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables sequence-parser
+USING: accessors arrays hashtables sequences.parser
 html.parser.utils kernel namespaces sequences math
 unicode.case unicode.categories combinators.short-circuit
 quoting fry ;

extra/io/serial/windows/windows.factor

@@ -11,8 +11,7 @@ IN: io.serial.windows
 
 : get-comm-state ( duplex -- dcb )
     in>> handle>>
-    DCB <struct> tuck
-    GetCommState win32-error=0/f ;
+    DCB <struct> [ GetCommState win32-error=0/f ] keep ;
 
 : set-comm-state ( duplex dcb -- )
     [ in>> handle>> ] dip

extra/jamshred/gl/gl.factor

@@ -3,7 +3,7 @@
 USING: accessors alien.c-types jamshred.game jamshred.oint
 jamshred.player jamshred.tunnel kernel math math.constants
 math.functions math.vectors opengl opengl.gl opengl.glu
-opengl.demo-support sequences specialized-arrays ;
+opengl.demo-support sequences specialized-arrays locals ;
 FROM: alien.c-types => float ;
 SPECIALIZED-ARRAY: float
 IN: jamshred.gl
@@ -50,8 +50,9 @@ CONSTANT: wall-drawing-offset 0.15
     over color>> gl-color segment-vertex-and-normal
     gl-normal gl-vertex ;
 
-: draw-vertex-pair ( theta next-segment segment -- )
-    rot tuck draw-segment-vertex draw-segment-vertex ;
+:: draw-vertex-pair ( theta next-segment segment -- )
+    segment theta draw-segment-vertex
+    next-segment theta draw-segment-vertex ;
 
 : draw-segment ( next-segment segment -- )
     GL_QUAD_STRIP [

extra/jamshred/oint/oint.factor

@@ -53,13 +53,13 @@ C: <oint> oint
 
 : scalar-projection ( v1 v2 -- n )
     #! the scalar projection of v1 onto v2
-    tuck v. swap norm / ;
+    [ v. ] [ norm ] bi / ;
 
 : proj-perp ( u v -- w )
     dupd proj v- ;
 
 : perpendicular-distance ( oint oint -- distance )
-    tuck distance-vector swap 2dup left>> scalar-projection abs
+    [ distance-vector ] keep 2dup left>> scalar-projection abs
     -rot up>> scalar-projection abs + ;
 
 :: reflect ( v n -- v' )

extra/jamshred/player/player.factor

@@ -31,16 +31,13 @@ CONSTANT: max-speed 30.0
     forward-pivot ;
 
 : to-tunnel-start ( player -- )
-    [ tunnel>> first dup location>> ]
-    [ tuck (>>location) (>>nearest-segment) ] bi ;
+    dup tunnel>> first
+    [ >>nearest-segment ]
+    [ location>> >>location ] bi drop ;
 
 : play-in-tunnel ( player segments -- )
     >>tunnel to-tunnel-start ;
 
-: update-nearest-segment ( player -- )
-    [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
-    [ (>>nearest-segment) ] tri ;
-
 : update-time ( player -- seconds-passed )
     millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
 

extra/jamshred/tunnel/tunnel-tests.factor

@@ -6,19 +6,6 @@ alien.c-types ;
 SPECIALIZED-ARRAY: float
 IN: jamshred.tunnel.tests
 
-[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
-        T{ segment f { 1 1 1 } f f f 1 }
-        T{ oint f { 0 0 0.25 } }
-        nearer-segment number>> ] unit-test
-
-[ 0 ] [ T{ oint f { 0 0 0 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
-[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
-[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
-
-[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test
-
-[ float-array{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test
-
 : test-segment-oint ( -- oint )
     { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;