steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Remove some usages of tuck

db4
Slava Pestov 2009-01-23 18:20:47 -06:00
parent a2cd1dd0e5
commit f34c14a0f5
57 changed files with 135 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/bootstrap/image/image.factor
View File

@ -433,7 +433,7 @@ M: quotation '
array>> '
quotation type-number object tag-number [
emit ! array
f ' emit ! compiled>>
f ' emit ! compiled
0 emit ! xt
0 emit ! code
] emit-object

2
basis/compiler/tests/codegen.factor
View File

@ -211,7 +211,7 @@ TUPLE: my-tuple ;
{ tuple vector } 3 slot { word } declare
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test
[ vector ] [ dispatch-alignment-regression ] unit-test

12
basis/compiler/tests/optimizer.factor
View File

@ -9,7 +9,7 @@ IN: optimizer.tests
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;
[ t ] [ \ xyz compiled>> ] unit-test
[ t ] [ \ xyz optimized>> ] unit-test
! Test predicate inlining
: pred-test-1
@ -94,7 +94,7 @@ TUPLE: pred-test ;
! regression
GENERIC: void-generic ( obj -- * )
: breakage ( -- * ) "hi" void-generic ;
[ t ] [ \ breakage compiled>> ] unit-test
[ t ] [ \ breakage optimized>> ] unit-test
[ breakage ] must-fail
! regression
@ -119,7 +119,7 @@ GENERIC: void-generic ( obj -- * )
! compiling <tuple> with a non-literal class failed
: <tuple>-regression ( class -- tuple ) <tuple> ;
[ t ] [ \ <tuple>-regression compiled>> ] unit-test
[ t ] [ \ <tuple>-regression optimized>> ] unit-test
GENERIC: foozul ( a -- b )
M: reversed foozul ;
@ -228,7 +228,7 @@ USE: binary-search.private
: node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
[ t ] [ \ node-successor-f-bug compiled>> ] unit-test
[ t ] [ \ node-successor-f-bug optimized>> ] unit-test
[ ] [ [ new ] build-tree optimize-tree drop ] unit-test
@ -242,7 +242,7 @@ USE: binary-search.private
] if
] if ;
[ t ] [ \ lift-throw-tail-regression compiled>> ] unit-test
[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
@ -271,7 +271,7 @@ HINTS: recursive-inline-hang array ;
: recursive-inline-hang-1 ( -- a )
{ } recursive-inline-hang ;
[ t ] [ \ recursive-inline-hang-1 compiled>> ] unit-test
[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test
DEFER: recursive-inline-hang-3

4
basis/compiler/tests/peg-regression.factor
View File

@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]]
USE: tools.test
[ t ] [ \ expr compiled>> ] unit-test
[ t ] [ \ ast>pipeline-expr compiled>> ] unit-test
[ t ] [ \ expr optimized>> ] unit-test
[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test

28
basis/compiler/tests/redefine1.factor
View File

@ -23,36 +23,36 @@ M: integer method-redefine-test 3 + ;
: hey ( -- ) ;
: there ( -- ) hey ;
[ t ] [ \ hey compiled>> ] unit-test
[ t ] [ \ there compiled>> ] unit-test
[ t ] [ \ hey optimized>> ] unit-test
[ t ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
[ f ] [ \ hey compiled>> ] unit-test
[ f ] [ \ there compiled>> ] unit-test
[ f ] [ \ hey optimized>> ] unit-test
[ f ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
[ t ] [ \ there compiled>> ] unit-test
[ t ] [ \ there optimized>> ] unit-test
: good ( -- ) ;
: bad ( -- ) good ;
: ugly ( -- ) bad ;
[ t ] [ \ good compiled>> ] unit-test
[ t ] [ \ bad compiled>> ] unit-test
[ t ] [ \ ugly compiled>> ] unit-test
[ t ] [ \ good optimized>> ] unit-test
[ t ] [ \ bad optimized>> ] unit-test
[ t ] [ \ ugly optimized>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
[ f ] [ \ good compiled>> ] unit-test
[ f ] [ \ bad compiled>> ] unit-test
[ f ] [ \ ugly compiled>> ] unit-test
[ f ] [ \ good optimized>> ] unit-test
[ f ] [ \ bad optimized>> ] unit-test
[ f ] [ \ ugly optimized>> ] unit-test
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
[ t ] [ \ good compiled>> ] unit-test
[ t ] [ \ bad compiled>> ] unit-test
[ t ] [ \ ugly compiled>> ] unit-test
[ t ] [ \ good optimized>> ] unit-test
[ t ] [ \ bad optimized>> ] unit-test
[ t ] [ \ ugly optimized>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test

4
basis/compiler/tests/redefine3.factor
View File

@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ;
: sheeple-test ( -- string ) { } sheeple ;
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test compiled>> ] unit-test
[ t ] [ \ sheeple-test optimized>> ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ;
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test compiled>> ] unit-test
[ t ] [ \ sheeple-test optimized>> ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

2
basis/compiler/tests/simple.factor
View File

@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval
] unit-test
] times

6
basis/compiler/tests/spilling.factor
View File

@ -47,7 +47,7 @@ IN: compiler.tests
[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
[ 1.0 float-spill-bug ] unit-test
[ t ] [ \ float-spill-bug compiled>> ] unit-test
[ t ] [ \ float-spill-bug optimized>> ] unit-test
: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
{
@ -132,7 +132,7 @@ IN: compiler.tests
[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
[ 1.0 float-fixnum-spill-bug ] unit-test
[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test
: resolve-spill-bug ( a b -- c )
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
@ -159,7 +159,7 @@ IN: compiler.tests
16 narray
] if ;
[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
[ t ] [ \ resolve-spill-bug optimized>> ] unit-test
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test

8
basis/cpu/ppc/assembler/assembler.factor
View File

@ -97,10 +97,10 @@ X: XOR 0 316 31
X: XOR. 1 316 31
X1: EXTSB 0 954 31
X1: EXTSB. 1 954 31
: FMR ( a s -- ) 0 -rot 72 0 63 x-insn ;
: FMR. ( a s -- ) 0 -rot 72 1 63 x-insn ;
: FCTIWZ ( a s -- ) 0 -rot 0 15 63 x-insn ;
: FCTIWZ. ( a s -- ) 0 -rot 1 15 63 x-insn ;
: FMR ( a s -- ) [ 0 ] 2dip 72 0 63 x-insn ;
: FMR. ( a s -- ) [ 0 ] 2dip 72 1 63 x-insn ;
: FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ;
: FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ;
! XO-form
XO: ADD 0 0 266 31

4
basis/cpu/ppc/assembler/backend/backend.factor
View File

@ -74,8 +74,8 @@ IN: cpu.ppc.assembler.backend
GENERIC# (B) 2 ( dest aa lk -- )
M: integer (B) 18 i-insn ;
M: word (B) 0 -rot (B) rc-relative-ppc-3 rel-word ;
M: label (B) 0 -rot (B) rc-relative-ppc-3 label-fixup ;
M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
GENERIC: BC ( a b c -- )
M: integer BC 0 0 16 b-insn ;

4
basis/db/postgresql/postgresql.factor
View File

@ -55,8 +55,10 @@ M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object )
[ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
M: postgresql-statement bind-tuple ( tuple statement -- )
tuck in-params>>
[ nip ] [
in-params>>
[ postgresql-bind-conversion ] with map
] 2bi
>>bind-params drop ;
M: postgresql-result-set #rows ( result-set -- n )

3
basis/db/tuples/tuples.factor
View File

@ -73,9 +73,10 @@ PRIVATE>
! High level
ERROR: no-slots-named class seq ;
: check-columns ( class columns -- )
tuck
[ nip ] [
[ [ first ] map ]
[ all-slots [ name>> ] map ] bi* diff
] 2bi
[ drop ] [ no-slots-named ] if-empty ;
: define-persistent ( class table columns -- )

4
basis/db/types/types.factor
View File

@ -42,10 +42,10 @@ ERROR: no-slot ;
slot-named dup [ no-slot ] unless offset>> ;
: get-slot-named ( name tuple -- value )
tuck offset-of-slot slot ;
[ nip ] [ offset-of-slot ] 2bi slot ;
: set-slot-named ( value name obj -- )
tuck offset-of-slot set-slot ;
[ nip ] [ offset-of-slot ] 2bi set-slot ;
ERROR: not-persistent class ;

4
basis/http/server/server.factor
View File

@ -196,8 +196,8 @@ LOG: httpd-hit NOTICE
LOG: httpd-header NOTICE
: log-header ( headers name -- )
tuck header 2array httpd-header ;
: log-header ( request name -- )
[ nip ] [ header ] 2bi 2array httpd-header ;
: log-request ( request -- )
[ [ method>> ] [ url>> ] bi 2array httpd-hit ]

3
basis/interval-maps/interval-maps.factor
View File

@ -31,7 +31,8 @@ PRIVATE>
: interval-at* ( key map -- value ? )
[ drop ] [ array>> find-interval ] 2bi
tuck interval-contains? [ third t ] [ drop f f ] if ;
[ nip ] [ interval-contains? ] 2bi
[ third t ] [ drop f f ] if ;
: interval-at ( key map -- value ) interval-at* drop ;

8
basis/io/directories/windows/windows.factor
View File

@ -33,13 +33,13 @@ M: windows delete-directory ( path -- )
RemoveDirectory win32-error=0/f ;
: find-first-file ( path -- WIN32_FIND_DATA handle )
"WIN32_FIND_DATA" <c-object> tuck
FindFirstFile
"WIN32_FIND_DATA" <c-object>
[ nip ] [ FindFirstFile ] 2bi
[ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
: find-next-file ( path -- WIN32_FIND_DATA/f )
"WIN32_FIND_DATA" <c-object> tuck
FindNextFile 0 = [
"WIN32_FIND_DATA" <c-object>
[ nip ] [ FindNextFile ] 2bi 0 = [
GetLastError ERROR_NO_MORE_FILES = [
win32-error
] unless drop f

3
basis/io/encodings/ascii/ascii.factor
View File

@ -9,7 +9,8 @@ IN: io.encodings.ascii
: decode-if< ( stream encoding max -- character )
nip swap stream-read1 dup
[ tuck > [ >fixnum ] [ drop replacement-char ] if ] [ 2drop f ] if ; inline
[ [ nip ] [ > ] 2bi [ >fixnum ] [ drop replacement-char ] if ]
[ 2drop f ] if ; inline
PRIVATE>
SINGLETON: ascii

4
basis/io/files/info/unix/freebsd/freebsd.factor
View File

@ -13,7 +13,7 @@ version io-size owner syncreads syncwrites asyncreads asyncwrites ;
M: freebsd new-file-system-info freebsd-file-system-info new ;
M: freebsd file-system-statfs ( path -- byte-array )
"statfs" <c-object> tuck statfs io-error ;
"statfs" <c-object> [ statfs io-error ] keep ;
M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-info )
{
@ -40,7 +40,7 @@ M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-inf
} cleave ;
M: freebsd file-system-statvfs ( path -- byte-array )
"statvfs" <c-object> tuck statvfs io-error ;
"statvfs" <c-object> [ statvfs io-error ] keep ;
M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
{

4
basis/io/files/info/unix/linux/linux.factor
View File

@ -14,7 +14,7 @@ namelen ;
M: linux new-file-system-info linux-file-system-info new ;
M: linux file-system-statfs ( path -- byte-array )
"statfs64" <c-object> tuck statfs64 io-error ;
"statfs64" <c-object> [ statfs64 io-error ] keep ;
M: linux statfs>file-system-info ( struct -- statfs )
{
@ -32,7 +32,7 @@ M: linux statfs>file-system-info ( struct -- statfs )
} cleave ;
M: linux file-system-statvfs ( path -- byte-array )
"statvfs64" <c-object> tuck statvfs64 io-error ;
"statvfs64" <c-object> [ statvfs64 io-error ] keep ;
M: linux statvfs>file-system-info ( struct -- statfs )
{

4
basis/io/files/info/unix/macosx/macosx.factor
View File

@ -20,10 +20,10 @@ M: macosx file-systems ( -- array )
M: macosx new-file-system-info macosx-file-system-info new ;
M: macosx file-system-statfs ( normalized-path -- statfs )
"statfs64" <c-object> tuck statfs64 io-error ;
"statfs64" <c-object> [ statfs64 io-error ] keep ;
M: macosx file-system-statvfs ( normalized-path -- statvfs )
"statvfs" <c-object> tuck statvfs io-error ;
"statvfs" <c-object> [ statvfs io-error ] keep ;
M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' )
{

2
basis/io/files/info/unix/netbsd/netbsd.factor
View File

@ -16,7 +16,7 @@ idx mount-from ;
M: netbsd new-file-system-info netbsd-file-system-info new ;
M: netbsd file-system-statvfs
"statvfs" <c-object> tuck statvfs io-error ;
"statvfs" <c-object> [ statvfs io-error ] keep ;
M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{

4
basis/io/files/info/unix/openbsd/openbsd.factor
View File

@ -14,7 +14,7 @@ owner ;
M: openbsd new-file-system-info freebsd-file-system-info new ;
M: openbsd file-system-statfs
"statfs" <c-object> tuck statfs io-error ;
"statfs" <c-object> [ statfs io-error ] keep ;
M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info' )
{
@ -41,7 +41,7 @@ M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info
} cleave ;
M: openbsd file-system-statvfs ( normalized-path -- statvfs )
"statvfs" <c-object> tuck statvfs io-error ;
"statvfs" <c-object> [ statvfs io-error ] keep ;
M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{

2
basis/io/ports/ports.factor
View File

@ -99,7 +99,7 @@ TUPLE: output-port < buffered-port ;
output-port <buffered-port> ;
: wait-to-write ( len port -- )
tuck buffer>> buffer-capacity <=
[ nip ] [ buffer>> buffer-capacity <= ] 2bi
[ drop ] [ stream-flush ] if ; inline
M: output-port stream-write1

2
basis/io/sockets/windows/nt/nt.factor
View File

@ -6,7 +6,7 @@ libc math sequences threads system combinators accessors ;
IN: io.sockets.windows.nt
: malloc-int ( object -- object )
"int" heap-size malloc tuck 0 set-alien-signed-4 ; inline
"int" heap-size malloc [ nip ] [ 0 set-alien-signed-4 ] 2bi ; inline
M: winnt WSASocket-flags ( -- DWORD )
WSA_FLAG_OVERLAPPED ;

2
basis/match/match.factor
View File

@ -80,7 +80,7 @@ MACRO: match-cond ( assoc -- )
(match-first) drop ;
: (match-all) ( seq pattern-seq -- )
tuck (match-first) swap
[ nip ] [ (match-first) swap ] 2bi
[
, [ swap (match-all) ] [ drop ] if*
] [ 2drop ] if* ;

8
basis/math/functions/functions.factor
View File

@ -122,11 +122,9 @@ PRIVATE>
[ * ] 2keep gcd nip /i ; foldable
: mod-inv ( x n -- y )
tuck gcd 1 = [
dup 0 < [ + ] [ nip ] if
] [
"Non-trivial divisor found" throw
] if ; foldable
[ nip ] [ gcd 1 = ] 2bi
[ dup 0 < [ + ] [ nip ] if ]
[ "Non-trivial divisor found" throw ] if ; foldable
: ^mod ( x y n -- z )
over 0 < [

3
basis/math/polynomials/polynomials.factor
View File

@ -68,7 +68,8 @@ PRIVATE>
dup V{ 0 } clone p= [
drop nip
] [
tuck p/mod [ pick p* swap [ swapd p- ] dip ] dip (pgcd)
[ nip ] [ p/mod ] 2bi
[ pick p* swap [ swapd p- ] dip ] dip (pgcd)
] if ;
PRIVATE>

2
basis/math/ratios/ratios.factor
View File

@ -24,7 +24,7 @@ M: integer /
"Division by zero" throw
] [
dup 0 < [ [ neg ] bi@ ] when
2dup gcd nip tuck /i [ /i ] dip fraction>
2dup gcd nip tuck [ /i ] 2bi@ fraction>
] if ;
M: ratio hashcode*

4
basis/mime/multipart/multipart.factor
View File

@ -54,7 +54,9 @@ ERROR: end-of-stream multipart ;
] if ;
: dump-until-separator ( multipart -- multipart )
dup [ current-separator>> ] [ bytes>> ] bi tuck start [
dup
[ current-separator>> ] [ bytes>> ] bi
[ nip ] [ start ] 2bi [
cut-slice
[ mime-write ]
[ over current-separator>> length tail-slice >>bytes ] bi*

3
basis/persistent/hashtables/nodes/leaf/leaf.factor
View File

@ -6,7 +6,8 @@ persistent.hashtables.nodes ;
IN: persistent.hashtables.nodes.leaf
: matching-key? ( key hashcode leaf-node -- ? )
tuck hashcode>> eq? [ key>> = ] [ 2drop f ] if ; inline
[ nip ] [ hashcode>> eq? ] 2bi
[ key>> = ] [ 2drop f ] if ; inline
M: leaf-node (entry-at) [ matching-key? ] keep and ;

3
basis/prettyprint/prettyprint.factor
View File

@ -248,7 +248,8 @@ GENERIC: declarations. ( obj -- )
M: object declarations. drop ;
: declaration. ( word prop -- )
tuck name>> word-prop [ pprint-word ] [ drop ] if ;
[ nip ] [ name>> word-prop ] 2bi
[ pprint-word ] [ drop ] if ;
M: word declarations.
{

2
basis/regexp/dfa/dfa.factor
View File

@ -72,7 +72,7 @@ IN: regexp.dfa
dup
[ nfa-traversal-flags>> ]
[ dfa-table>> transitions>> keys ] bi
[ tuck [ swap at ] with map concat ] with H{ } map>assoc
[ [ nip ] [ [ swap at ] with map concat ] 2bi ] with H{ } map>assoc
>>dfa-traversal-flags drop ;
: construct-dfa ( regexp -- )

2
basis/regexp/parser/parser.factor
View File

@ -63,7 +63,7 @@ left-parenthesis pipe caret dash ;
: cut-out ( vector n -- vector' vector ) cut rest ;
ERROR: cut-stack-error ;
: cut-stack ( obj vector -- vector' vector )
tuck last-index [ cut-stack-error ] unless* cut-out swap ;
[ nip ] [ last-index ] 2bi [ cut-stack-error ] unless* cut-out swap ;
: <possessive-kleene-star> ( obj -- kleene ) possessive-kleene-star boa ;
: <reluctant-kleene-star> ( obj -- kleene ) reluctant-kleene-star boa ;

2
basis/regexp/transition-tables/transition-tables.factor
View File

@ -35,7 +35,7 @@ TUPLE: transition-table transitions start-state final-states ;
H{ } clone >>final-states ;
: maybe-initialize-key ( key hashtable -- )
2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ;
2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ;
: set-transition ( transition hash -- )
#! set the state as a key

3
basis/serialize/serialize.factor
View File

@ -221,8 +221,7 @@ SYMBOL: deserialized
(deserialize) (deserialize) 2dup lookup
dup [ 2nip ] [
drop
"Unknown word: " -rot
2array unparse append throw
2array unparse "Unknown word: " prepend throw
] if ;
: deserialize-gensym ( -- word )

2
basis/syndication/syndication.factor
View File

@ -9,7 +9,7 @@ USING: xml.utilities kernel assocs xml.generator math.order
IN: syndication
: any-tag-named ( tag names -- tag-inside )
f -rot [ tag-named nip dup ] with find 2drop ;
[ f ] 2dip [ tag-named nip dup ] with find 2drop ;
TUPLE: feed title url entries ;

2
basis/ui/gadgets/editors/editors.factor
View File

@ -350,7 +350,7 @@ M: editor gadget-text* editor-string % ;
dupd editor-select-next mark>caret ;
: editor-select ( from to editor -- )
tuck caret>> set-model mark>> set-model ;
tuck [ mark>> set-model ] [ caret>> set-model ] 2bi* ;
: select-elt ( editor elt -- )
[ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi

13
basis/ui/gadgets/gadgets.factor
View File

@ -165,7 +165,9 @@ M: gadget dim-changed
in-layout? get [ invalidate ] [ invalidate* ] if ;
M: gadget (>>dim) ( dim gadget -- )
2dup dim>> = [ 2drop ] [ tuck call-next-method dim-changed ] if ;
2dup dim>> =
[ 2drop ]
[ [ nip ] [ call-next-method ] 2bi dim-changed ] if ;
GENERIC: pref-dim* ( gadget -- dim )
@ -250,7 +252,7 @@ M: gadget ungraft* drop ;
f >>parent drop ;
: unfocus-gadget ( child gadget -- )
tuck focus>> eq? [ f >>focus ] when drop ;
[ nip ] [ focus>> eq? ] 2bi [ f >>focus ] when drop ;
SYMBOL: in-layout?
@ -286,10 +288,7 @@ SYMBOL: in-layout?
dup unparent
over >>parent
tuck ((add-gadget))
tuck graft-state>> second
[ graft ]
[ drop ]
if ;
tuck graft-state>> second [ graft ] [ drop ] if ;
: add-gadget ( parent child -- parent )
not-in-layout
@ -316,7 +315,7 @@ SYMBOL: in-layout?
: (screen-rect) ( gadget -- loc ext )
dup parent>> [
[ rect-extent ] dip (screen-rect)
[ tuck v+ ] dip vmin [ v+ ] dip
[ [ nip ] [ v+ ] 2bi ] dip [ vmin ] [ v+ ] 2bi*
] [
rect-extent
] if* ;

2
basis/ui/gadgets/incremental/incremental.factor
View File

@ -23,7 +23,7 @@ M: incremental pref-dim*
] keep orientation>> set-axis ;
: update-cursor ( gadget incremental -- )
tuck next-cursor >>cursor drop ;
[ nip ] [ next-cursor ] 2bi >>cursor drop ;
: incremental-loc ( gadget incremental -- )
[ cursor>> ] [ orientation>> ] bi v*

2
basis/unicode/breaks/breaks.factor
View File

@ -96,7 +96,7 @@ PRIVATE>
: first-grapheme ( str -- i )
unclip-slice grapheme-class over
[ grapheme-class tuck grapheme-break? ] find drop
[ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop
nip swap length or 1+ ;
<PRIVATE

2
basis/unicode/collation/collation.factor
View File

@ -125,7 +125,7 @@ PRIVATE>
: filter-ignorable ( weights -- weights' )
f swap [
tuck primary>> zero? and
[ nip ] [ primary>> zero? and ] 2bi
[ swap ignorable?>> or ]
[ swap completely-ignorable? or not ] 2bi
] filter nip ;

4
basis/unix/unix.factor
View File

@ -155,8 +155,8 @@ FUNCTION: int utime ( char* path, utimebuf* buf ) ;
: change-file-times ( filename access modification -- )
"utimebuf" <c-object>
tuck set-utimbuf-modtime
tuck set-utimbuf-actime
[ set-utimbuf-modtime ] keep
[ set-utimbuf-actime ] keep
[ utime ] unix-system-call drop ;
FUNCTION: int pclose ( void* file ) ;

2
basis/x11/clipboard/clipboard.factor
View File

@ -41,7 +41,7 @@ TUPLE: x-clipboard atom contents ;
] if ;
: own-selection ( prop win -- )
dpy get -rot CurrentTime XSetSelectionOwner drop
[ dpy get ] 2dip CurrentTime XSetSelectionOwner drop
flush-dpy ;
: set-targets-prop ( evt -- )

2
basis/x11/windows/windows.factor
View File

@ -37,7 +37,7 @@ IN: x11.windows
: set-size-hints ( window -- )
"XSizeHints" <c-object>
USPosition over set-XSizeHints-flags
dpy get -rot XSetWMNormalHints ;
[ dpy get ] 2dip XSetWMNormalHints ;
: auto-position ( window loc -- )
{ 0 0 } = [ drop ] [ set-size-hints ] if ;

3
basis/xml/data/data.factor
View File

@ -62,7 +62,8 @@ M: attrs assoc-like
M: attrs clear-assoc
f >>alist drop ;
M: attrs delete-at
tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ;
[ nip ] [ attr@ drop ] 2bi
[ swap alist>> delete-nth ] [ drop ] if* ;
M: attrs clone
alist>> clone <attrs> ;

2
basis/xmode/marker/marker.factor
View File

@ -100,7 +100,7 @@ DEFER: get-rules
[ ch>upper ] dip rules>> at ?push-all ;
: get-rules ( char ruleset -- seq )
f -rot [ get-char-rules ] keep get-always-rules ;
[ f ] 2dip [ get-char-rules ] keep get-always-rules ;
GENERIC: handle-rule-start ( match-count rule -- )

2
basis/xmode/utilities/utilities.factor
View File

@ -7,7 +7,7 @@ IN: xmode.utilities
: child-tags ( tag -- seq ) children>> [ tag? ] filter ;
: map-find ( seq quot -- result elt )
f -rot
[ f ] 2dip
'[ nip @ dup ] find
[ [ drop f ] unless ] dip ; inline

2
core/assocs/assocs.factor
View File

@ -188,7 +188,7 @@ M: sequence new-assoc drop <vector> ;
M: sequence clear-assoc delete-all ;
M: sequence delete-at
tuck search-alist nip
[ nip ] [ search-alist nip ] 2bi
[ swap delete-nth ] [ drop ] if* ;
M: sequence assoc-size length ;

2
core/classes/algebra/algebra.factor
View File

@ -215,7 +215,7 @@ M: anonymous-complement (classes-intersect?)
: min-class ( class seq -- class/f )
over [ classes-intersect? ] curry filter
[ drop f ] [
tuck [ class<= ] with all? [ peek ] [ drop f ] if
[ nip ] [ [ class<= ] with all? ] 2bi [ peek ] [ drop f ] if
] if-empty ;
GENERIC: (flatten-class) ( class -- )

2
core/classes/classes.factor
View File

@ -162,7 +162,7 @@ GENERIC: update-methods ( class seq -- )
dup "predicate" word-prop
dup length 1 = [
first
tuck "predicating" word-prop =
[ nip ] [ "predicating" word-prop = ] 2bi
[ forget ] [ drop ] if
] [ 2drop ] if ;

2
core/classes/mixin/mixin.factor
View File

@ -54,7 +54,7 @@ TUPLE: check-mixin-class class ;
#! class-usages of the member, now that it's been added.
[ 2drop ] [
[ [ suffix ] change-mixin-class ] 2keep
tuck [ new-class? ] either? [
[ nip ] [ [ new-class? ] either? ] 2bi [
update-classes/new
] [
update-classes

18
core/compiler/units/units-tests.factor
View File

@ -1,6 +1,6 @@
IN: compiler.units.tests
USING: definitions compiler.units tools.test arrays sequences words kernel
accessors ;
accessors namespaces fry ;
[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test
[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test
@ -9,8 +9,22 @@ accessors ;
[ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test
[ called-dependency ] [ called-dependency f strongest-dependency ] unit-test
! Non-optimizing compiler bug
! Non-optimizing compiler bugs
[ 1 1 ] [
"A" "B" <word> [ [ 1 ] dip ] >>def dup f 2array 1array f modify-code-heap
1 swap execute
] unit-test
[ "A" "B" ] [
gensym "a" set
gensym "b" set
[
"a" get [ "A" ] define
"b" get "a" get '[ _ execute ] define
] with-compilation-unit
"b" get execute
[
"a" get [ "B" ] define
] with-compilation-unit
"b" get execute
] unit-test

2
core/effects/parser/parser.factor
View File

@ -9,7 +9,7 @@ DEFER: parse-effect
ERROR: bad-effect ;
: parse-effect-token ( end -- token/f )
scan tuck = [ drop f ] [
scan [ nip ] [ = ] 2bi [ drop f ] [
dup { f "(" "((" } member? [ bad-effect ] [
":" ?tail [
scan-word {

3
core/generic/generic.factor
View File

@ -36,7 +36,8 @@ PREDICATE: method-spec < pair
"methods" word-prop keys sort-classes ;
: specific-method ( class generic -- method/f )
tuck order min-class dup [ swap method ] [ 2drop f ] if ;
[ nip ] [ order min-class ] 2bi
dup [ swap method ] [ 2drop f ] if ;
GENERIC: effective-method ( generic -- method )

2
core/hashtables/hashtables.factor
View File

@ -104,7 +104,7 @@ M: hashtable clear-assoc ( hash -- )
[ init-hash ] [ array>> [ drop ((empty)) ] change-each ] bi ;
M: hashtable delete-at ( key hash -- )
tuck key@ [
[ nip ] [ key@ ] 2bi [
[ ((tombstone)) dup ] 2dip set-nth-pair
hash-deleted+
] [

2
core/parser/parser.factor
View File

@ -254,7 +254,7 @@ print-use-hook global [ [ ] or ] change-at
[
[
lines dup parse-fresh
tuck finish-parsing
[ nip ] [ finish-parsing ] 2bi
forget-smudged
] with-source-file
] with-compilation-unit ;

12
core/sequences/sequences.factor
View File

@ -138,15 +138,15 @@ INSTANCE: iota immutable-sequence
: from-end ( seq n -- seq n' ) [ dup length ] dip - ; inline
: (2sequence) ( obj1 obj2 seq -- seq )
tuck 1 swap set-nth-unsafe
tuck 0 swap set-nth-unsafe ; inline
[ 1 swap set-nth-unsafe ] keep
[ 0 swap set-nth-unsafe ] keep ; inline
: (3sequence) ( obj1 obj2 obj3 seq -- seq )
tuck 2 swap set-nth-unsafe
[ 2 swap set-nth-unsafe ] keep
(2sequence) ; inline
: (4sequence) ( obj1 obj2 obj3 obj4 seq -- seq )
tuck 3 swap set-nth-unsafe
[ 3 swap set-nth-unsafe ] keep
(3sequence) ; inline
PRIVATE>
@ -723,14 +723,14 @@ PRIVATE>
2dup shorter? [
2drop f
] [
tuck length head-slice sequence=
[ nip ] [ length head-slice ] 2bi sequence=
] if ;
: tail? ( seq end -- ? )
2dup shorter? [
2drop f
] [
tuck length tail-slice* sequence=
[ nip ] [ length tail-slice* ] 2bi sequence=
] if ;
: cut-slice ( seq n -- before-slice after-slice )