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

core: Add the shuffler words but without primitives. 

The nipd branch slowed bootstrap by a minute, this patch does not.

sorry about changing the fjsc line endings...
paths
Doug Coleman 2018-06-19 19:15:05 -05:00
parent c477757fa0
commit 9f213f96f6
153 changed files with 1523 additions and 1494 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alien/libraries/libraries.factor
View File

@ -65,7 +65,7 @@ M: library dispose dll>> [ dispose ] when* ;
: add-library ( name path abi -- ) : add-library ( name path abi -- )
3dup add-library? [ 3dup add-library? [
[ 2drop remove-library ] [ 2drop remove-library ]
[ [ nip ] dip make-library ] [ nipd make-library ]
[ 2drop libraries get set-at ] 3tri [ 2drop libraries get set-at ] 3tri
] [ 3drop ] if ; ] [ 3drop ] if ;

4
basis/calendar/parser/parser.factor
View File

@ -104,7 +104,7 @@ CONSTANT: rfc822-named-zones H{
read1 CHAR: \s assert= read1 CHAR: \s assert=
read-sp checked-number read-sp checked-number
read-sp month-abbreviations index 1 + check-timestamp read-sp month-abbreviations index 1 + check-timestamp
read-sp checked-number -rot swap read-sp checked-number spin
read-hh:mm:ss read-hh:mm:ss
" " read-until drop parse-rfc822-gmt-offset <timestamp> ; " " read-until drop parse-rfc822-gmt-offset <timestamp> ;
@ -120,7 +120,7 @@ CONSTANT: rfc822-named-zones H{
read1 CHAR: \s assert= read1 CHAR: \s assert=
"-" read-token checked-number "-" read-token checked-number
"-" read-token month-abbreviations index 1 + check-timestamp "-" read-token month-abbreviations index 1 + check-timestamp
read-sp checked-number -rot swap read-sp checked-number spin
read-hh:mm:ss read-hh:mm:ss
" " read-until drop parse-rfc822-gmt-offset <timestamp> ; " " read-until drop parse-rfc822-gmt-offset <timestamp> ;

2
basis/checksums/ripemd/ripemd.factor
View File

@ -39,7 +39,7 @@ M: ripemd-160 initialize-checksum-state drop <ripemd-160-state> ;
: F ( x y z -- out ) bitxor bitxor ; inline : F ( x y z -- out ) bitxor bitxor ; inline
: G ( x y z -- out ) pick bitnot swap [ bitand ] 2bi@ bitor ; inline : G ( x y z -- out ) pick bitnot swap [ bitand ] 2bi@ bitor ; inline
: H ( x y z -- out ) [ bitnot bitor ] [ bitxor ] bi* ; inline : H ( x y z -- out ) [ bitnot bitor ] [ bitxor ] bi* ; inline
: I ( x y z -- out ) swap over bitnot [ bitand ] 2bi@ bitor ; inline : I ( x y z -- out ) tuck bitnot [ bitand ] 2bi@ bitor ; inline
: J ( x y z -- out ) bitnot bitor bitxor ; inline : J ( x y z -- out ) bitnot bitor bitxor ; inline
CONSTANT: T11 0x00000000 CONSTANT: T11 0x00000000

2
basis/checksums/sha/sha-tests.factor
View File

@ -84,7 +84,7 @@ CONSTANT: bytes-b B{ 1 2 3 4 5 6 7 8 }
ERROR: checksums-differ algorithm seq incremental-checksum one-go-checksum ; ERROR: checksums-differ algorithm seq incremental-checksum one-go-checksum ;
: compare-checksum-calculations ( algorithm seq -- ? ) : compare-checksum-calculations ( algorithm seq -- ? )
2dup [ incremental-checksum ] [ one-go-checksum ] 2bi 2dup = [ 2dup [ incremental-checksum ] [ one-go-checksum ] 2bi 2dup = [
2drop 2drop t 4drop t
] [ ] [
checksums-differ checksums-differ
] if ; ] if ;

4
basis/classes/struct/struct.factor
View File

@ -135,7 +135,7 @@ PRIVATE>
M: struct-class boa>object M: struct-class boa>object
swap pad-struct-slots swap pad-struct-slots
[ <struct> ] [ struct-slots ] bi [ <struct> ] [ struct-slots ] bi
[ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ; [ [ (writer-quot) call( value struct -- ) ] with 2each ] keepd ;
M: struct-class initial-value* <struct> t ; inline M: struct-class initial-value* <struct> t ; inline
@ -262,7 +262,7 @@ M: struct binary-zero? binary-object uchar <c-direct-array> [ 0 = ] all? ; inlin
[ [
[ initial>> ] [ initial>> ]
[ (writer-quot) ] bi [ (writer-quot) ] bi
over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if over [ swapd [ call( value struct -- ) ] keepd ] [ 2drop ] if
] each ] each
] [ drop f ] if ; ] [ drop f ] if ;

2
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -102,7 +102,7 @@ RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
} cleave ; } cleave ;
: change-insn-gc-roots ( gc-map-insn quot: ( x -- x ) -- ) : change-insn-gc-roots ( gc-map-insn quot: ( x -- x ) -- )
[ gc-map>> ] dip [ swap gc-roots>> swap map! drop ] [ gc-map>> ] dip [ [ gc-roots>> ] dip map! drop ]
[ '[ [ _ bi@ ] assoc-map ] change-derived-roots drop ] 2bi ; inline [ '[ [ _ bi@ ] assoc-map ] change-derived-roots drop ] 2bi ; inline
: spill-required? ( live-interval root-leaders n -- ? ) : spill-required? ( live-interval root-leaders n -- ? )

2
basis/compiler/cfg/stacks/local/local-tests.factor
View File

@ -146,7 +146,7 @@ IN: compiler.cfg.stacks.local.tests
: my-new-key4 ( a i j -- i/j ) : my-new-key4 ( a i j -- i/j )
2over 2over
slot slot
swap over tuck
! a i el j el ! a i el j el
[ [
! a i el j ! a i el j

2
basis/compiler/cfg/stacks/stacks.factor
View File

@ -21,7 +21,7 @@ IN: compiler.cfg.stacks
} apply-passes ; } apply-passes ;
: create-locs ( loc-class seq -- locs ) : create-locs ( loc-class seq -- locs )
[ swap new swap >>n ] with map <reversed> ; [ [ new ] dip >>n ] with map <reversed> ;
: stack-locs ( loc-class n -- locs ) : stack-locs ( loc-class n -- locs )
<iota> create-locs ; <iota> create-locs ;

4
basis/compiler/cfg/value-numbering/simd/simd.factor
View File

@ -85,8 +85,8 @@ M: ##gather-int-vector-2 rewrite rewrite-gather-vector-2 ;
: rewrite-gather-vector-4 ( insn -- insn/f ) : rewrite-gather-vector-4 ( insn -- insn/f )
dup { [ src1>> ] [ src2>> ] [ src3>> ] [ src4>> ] } cleave [ vreg>insn ] 4 napply dup { [ src1>> ] [ src2>> ] [ src3>> ] [ src4>> ] } cleave [ vreg>insn ] 4 napply
{ {
{ [ 4 ndup [ literal-insn? ] 4 napply and and and ] [ fold-gather-vector-4 ] } { [ 4dup [ literal-insn? ] 4 napply and and and ] [ fold-gather-vector-4 ] }
[ 5 ndrop f ] [ 5drop f ]
} cond ; } cond ;
M: ##gather-vector-4 rewrite rewrite-gather-vector-4 ; M: ##gather-vector-4 rewrite rewrite-gather-vector-4 ;

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

@ -151,7 +151,7 @@ unit-test
: multi_ffi_test_18 ( w x y z w' x' y' z' -- int int ) : multi_ffi_test_18 ( w x y z w' x' y' z' -- int int )
[ int "f-stdcall" "ffi_test_18" { int int int int } f alien-invoke ] [ int "f-stdcall" "ffi_test_18" { int int int int } f alien-invoke ]
4 ndip 4dip
int "f-stdcall" "ffi_test_18" { int int int int } f alien-invoke int "f-stdcall" "ffi_test_18" { int int int int } f alien-invoke
gc ; gc ;
@ -917,11 +917,11 @@ FUNCTION: void* bug1021_test_1 ( void* s, int x )
] [ 2drop ] if ; inline recursive ] [ 2drop ] if ; inline recursive
: run-test ( alien -- seq ) : run-test ( alien -- seq )
100 33 <array> swap over 100 33 <array> tuck
[ [
pick swapd pick swapd
bug1021_test_1 bug1021_test_1
-rot swap 2 fixnum+fast spin 2 fixnum+fast
set-slot set-slot
] curry curry 0 each-to100 ; ] curry curry 0 each-to100 ;

2
basis/compiler/tree/propagation/simd/simd.factor
View File

@ -124,7 +124,7 @@ vector>vector-intrinsics [ { byte-array } "default-output-classes" set-word-prop
: inline-unless-intrinsic ( word -- ) : inline-unless-intrinsic ( word -- )
dup '[ dup '[
_ swap over "intrinsic" word-prop _ tuck "intrinsic" word-prop
"always-inline-simd-intrinsics" get not swap and "always-inline-simd-intrinsics" get not swap and
! word node intrinsic ! word node intrinsic
[ try-intrinsic [ drop f ] [ def>> ] if ] [ try-intrinsic [ drop f ] [ def>> ] if ]

2
basis/compression/snappy/snappy.factor
View File

@ -29,4 +29,4 @@ PRIVATE>
[ snappy_uncompressed_length check-snappy ] keep [ snappy_uncompressed_length check-snappy ] keep
size_t deref size_t deref
n>outs n>outs
[ snappy_uncompress check-snappy ] 2keep drop >byte-array ; [ snappy_uncompress check-snappy ] keepd >byte-array ;

16
basis/compression/zlib/zlib.factor
View File

@ -37,7 +37,7 @@ ERROR: zlib-failed n string ;
[ <byte-vector> dup underlying>> ] keep ulong <ref> [ <byte-vector> dup underlying>> ] keep ulong <ref>
] keep [ ] keep [
dup length compression.zlib.ffi:compress zlib-error dup length compression.zlib.ffi:compress zlib-error
] 2keep drop ulong deref >>length B{ } like ; ] keepd ulong deref >>length B{ } like ;
: (uncompress) ( length byte-array -- byte-array ) : (uncompress) ( length byte-array -- byte-array )
[ [
@ -53,15 +53,13 @@ ERROR: zlib-failed n string ;
: zlib-inflate-init ( -- z_stream_s ) : zlib-inflate-init ( -- z_stream_s )
z_stream <struct> ZLIB_VERSION over byte-length [ z_stream <struct>
inflateInit_ zlib-error dup ZLIB_VERSION over byte-length inflateInit_ zlib-error ;
] 3keep 2drop ;
! window can be 0, 15, 32, 47 (others?) ! window can be 0, 15, 32, 47 (others?)
: zlib-inflate-init2 ( window -- z_stream_s ) : zlib-inflate-init2 ( window -- z_stream_s )
[ z_stream <struct> ] dip ZLIB_VERSION pick byte-length [ [ z_stream <struct> dup ] dip
inflateInit2_ zlib-error ZLIB_VERSION pick byte-length inflateInit2_ zlib-error ;
] 4keep 3drop ;
: zlib-inflate-end ( z_stream -- ) : zlib-inflate-end ( z_stream -- )
inflateEnd zlib-error ; inflateEnd zlib-error ;
@ -73,6 +71,4 @@ ERROR: zlib-failed n string ;
inflate zlib-error ; inflate zlib-error ;
: zlib-inflate-get-header ( z_stream -- gz_header ) : zlib-inflate-get-header ( z_stream -- gz_header )
gz_header <struct> [ gz_header <struct> [ inflateGetHeader zlib-error ] keep ;
inflateGetHeader zlib-error
] keep ;

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

@ -1949,8 +1949,8 @@ tri* 134 1 63 x-insn ;
: CLRLDI. ( ra rs n -- ) 0 swap RLDICL. ; : CLRLDI. ( ra rs n -- ) 0 swap RLDICL. ;
: CLRRDI ( ra rs n -- ) 0 swap 63 swap - RLDICR ; : CLRRDI ( ra rs n -- ) 0 swap 63 swap - RLDICR ;
: CLRRDI. ( ra rs n -- ) 0 swap 63 swap - RLDICR. ; : CLRRDI. ( ra rs n -- ) 0 swap 63 swap - RLDICR. ;
: CLRLSLDI ( ra rs b n -- ) swap over - RLDIC ; : CLRLSLDI ( ra rs b n -- ) tuck - RLDIC ;
: CLRLSLDI. ( ra rs b n -- ) swap over - RLDIC. ; : CLRLSLDI. ( ra rs b n -- ) tuck - RLDIC. ;
! E.7.2 Operations on Words ! E.7.2 Operations on Words
: EXTLWI ( ra rs n b -- ) swap 0 1 - RLWINM ; : EXTLWI ( ra rs n b -- ) swap 0 1 - RLWINM ;

2
basis/cpu/x86/assembler/assembler.factor
View File

@ -147,7 +147,7 @@ M: register displacement, drop ;
: 1-operand ( operand reg,rex.w,opcode -- ) : 1-operand ( operand reg,rex.w,opcode -- )
! The 'reg' is not really a register, but a value for the ! The 'reg' is not really a register, but a value for the
! 'reg' field of the mod-r/m byte. ! 'reg' field of the mod-r/m byte.
first3 [ [ over ] dip prefix-1 ] dip opcode, swap addressing ; first3 [ overd prefix-1 ] dip opcode, swap addressing ;
: immediate-operand-size-bit ( dst imm reg,rex.w,opcode -- imm dst reg,rex.w,opcode ) : immediate-operand-size-bit ( dst imm reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
over integer? [ first3 0b1 opcode-or 3array ] when ; over integer? [ first3 0b1 opcode-or 3array ] when ;

2
basis/cpu/x86/x86.factor
View File

@ -409,7 +409,7 @@ M: x86 %convert-integer ( dst src c-type -- )
{ c:int [ 32 %alien-signed-getter ] } { c:int [ 32 %alien-signed-getter ] }
{ c:uint [ 32 [ 2drop ] %alien-integer-getter ] } { c:uint [ 32 [ 2drop ] %alien-integer-getter ] }
} case } case
] [ [ drop ] 2dip %copy ] ?if ; ] [ nipd %copy ] ?if ;
M: x86 %load-memory ( dst base displacement scale offset rep c-type -- ) M: x86 %load-memory ( dst base displacement scale offset rep c-type -- )
(%memory) (%load-memory) ; (%memory) (%load-memory) ;

8
basis/csv/csv.factor
View File

@ -17,7 +17,7 @@ MEMO: field-delimiters ( delimiter -- field-seps quote-seps )
DEFER: quoted-field, DEFER: quoted-field,
: maybe-escaped-quote ( delimeter stream quoted? -- delimiter stream sep/f ) : maybe-escaped-quote ( delimeter stream quoted? -- delimiter stream sep/f )
2over stream-read1 swap over = 2over stream-read1 tuck =
[ nip ] [ [ nip ] [
{ {
{ CHAR: \" [ [ CHAR: \" , ] when quoted-field, ] } { CHAR: \" [ [ CHAR: \" , ] when quoted-field, ] }
@ -42,12 +42,12 @@ DEFER: quoted-field,
: continue-field ( delimiter stream field-seps seq -- sep/f field ) : continue-field ( delimiter stream field-seps seq -- sep/f field )
swap rot stream-read-until [ "\"" glue ] dip swap rot stream-read-until [ "\"" glue ] dip
swap ?trim [ drop ] 2dip ; inline swap ?trim nipd ; inline
: field ( delimiter stream field-seps quote-seps -- sep/f field ) : field ( delimiter stream field-seps quote-seps -- sep/f field )
pick stream-read-until dup CHAR: \" = [ pick stream-read-until dup CHAR: \" = [
drop [ drop quoted-field ] [ continue-field ] if-empty drop [ drop quoted-field ] [ continue-field ] if-empty
] [ [ 3drop ] 2dip swap ?trim ] if ; ] [ 3nipd swap ?trim ] if ;
: (stream-read-row) ( delimiter stream field-end quoted-field -- sep/f fields ) : (stream-read-row) ( delimiter stream field-end quoted-field -- sep/f fields )
[ [ dup '[ dup _ = ] ] keep ] 3dip [ [ dup '[ dup _ = ] ] keep ] 3dip
@ -61,7 +61,7 @@ DEFER: quoted-field,
PRIVATE> PRIVATE>
: stream-read-row ( stream -- row ) : stream-read-row ( stream -- row )
delimiter get swap over field-delimiters delimiter get tuck field-delimiters
(stream-read-row) nip ; inline (stream-read-row) nip ; inline
: read-row ( -- row ) : read-row ( -- row )

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

@ -118,7 +118,7 @@ M: postgresql-result-null summary ( obj -- str )
: pq-get-string ( handle row column -- obj ) : pq-get-string ( handle row column -- obj )
3dup PQgetvalue utf8 alien>string 3dup PQgetvalue utf8 alien>string
dup empty? [ [ pq-get-is-null f ] dip ? ] [ [ 3drop ] dip ] if ; dup empty? [ [ pq-get-is-null f ] dip ? ] [ 3nip ] if ;
: pq-get-number ( handle row column -- obj ) : pq-get-number ( handle row column -- obj )
pq-get-string dup [ string>number ] when ; pq-get-string dup [ string>number ] when ;
@ -135,7 +135,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
: pq-get-blob ( handle row column -- obj/f ) : pq-get-blob ( handle row column -- obj/f )
[ PQgetvalue ] 3keep 3dup PQgetlength [ PQgetvalue ] 3keep 3dup PQgetlength
dup 0 > [ dup 0 > [
[ 3drop ] dip 3nip
[ [
memory>byte-array >string memory>byte-array >string
{ uint } { uint }

4
basis/formatting/formatting.factor
View File

@ -37,7 +37,7 @@ ERROR: unknown-format-directive value ;
[ 10^ * round-to-even >integer number>string ] [ 10^ * round-to-even >integer number>string ]
[ 1 + CHAR: 0 pad-head ] [ 1 + CHAR: 0 pad-head ]
[ cut* ] tri [ "." glue ] unless-empty [ cut* ] tri [ "." glue ] unless-empty
] curry keep neg? [ CHAR: - prefix ] when ; ] keepd neg? [ CHAR: - prefix ] when ;
: format-scientific-mantissa ( x log10x digits -- string rounded-up? ) : format-scientific-mantissa ( x log10x digits -- string rounded-up? )
[ swap - 10^ * round-to-even >integer number>string ] keep [ swap - 10^ * round-to-even >integer number>string ] keep
@ -55,7 +55,7 @@ ERROR: unknown-format-directive value ;
[ abs dup integer-log10 ] dip [ abs dup integer-log10 ] dip
[ format-scientific-mantissa ] [ format-scientific-mantissa ]
[ drop nip format-scientific-exponent ] 3bi append [ drop nip format-scientific-exponent ] 3bi append
] curry keep neg? [ CHAR: - prefix ] when ; ] keepd neg? [ CHAR: - prefix ] when ;
: format-float-fast ( x digits string -- string ) : format-float-fast ( x digits string -- string )
[ "" -1 ] 2dip "C" format-float ; [ "" -1 ] 2dip "C" format-float ;

4
basis/fry/fry.factor
View File

@ -110,7 +110,7 @@ TUPLE: dredge-fry-state
: in-quot-slices ( n i state -- head tail ) : in-quot-slices ( n i state -- head tail )
in-quot>> in-quot>>
[ <slice> ] [ <slice> ]
[ [ drop ] 2dip swap 1 + tail-slice ] 3bi ; inline [ nipd swap 1 + tail-slice ] 3bi ; inline
: push-head-slice ( head state -- ) : push-head-slice ( head state -- )
quot>> [ push-all ] [ \ _ swap push ] bi ; inline quot>> [ push-all ] [ \ _ swap push ] bi ; inline
@ -122,7 +122,7 @@ TUPLE: dredge-fry-state
rot { rot {
[ nip in-quot-slices ] ! head tail i elt state [ nip in-quot-slices ] ! head tail i elt state
[ [ 2drop swap ] dip push-head-slice ] [ [ 2drop swap ] dip push-head-slice ]
[ [ drop ] 2dip push-subquot ] [ nipd push-subquot ]
[ [ 1 + ] [ drop ] [ ] tri* dredge-fry ] [ [ 1 + ] [ drop ] [ ] tri* dredge-fry ]
} 3cleave ; inline recursive } 3cleave ; inline recursive

2
basis/furnace/chloe-tags/chloe-tags.factor
View File

@ -32,7 +32,7 @@ IN: furnace.chloe-tags
[ [ "/" ?tail drop "/" ] dip present 3append ] when* ; [ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
: a-url ( href rest query value-name -- url ) : a-url ( href rest query value-name -- url )
dup [ [ 3drop ] dip value ] [ dup [ 3nip value ] [
drop drop
<url> <url>
swap parse-query-attr >>query swap parse-query-attr >>query

2
basis/game/input/dinput/dinput.factor
View File

@ -176,7 +176,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
<alien> DEV_BROADCAST_HDR memory>struct ; <alien> DEV_BROADCAST_HDR memory>struct ;
: handle-wm-devicechange ( hWnd uMsg wParam lParam -- ) : handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
[ 2drop ] 2dip swap { 2nipd swap {
{ [ dup DBT_DEVICEARRIVAL = ] [ drop <DEV_BROADCAST_HDR> device-arrived ] } { [ dup DBT_DEVICEARRIVAL = ] [ drop <DEV_BROADCAST_HDR> device-arrived ] }
{ [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <DEV_BROADCAST_HDR> device-removed ] } { [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <DEV_BROADCAST_HDR> device-removed ] }
[ 2drop ] [ 2drop ]

2
basis/game/input/gtk/gtk.factor
View File

@ -98,7 +98,7 @@ M: gtk-game-input-backend read-keyboard
get-dpy dup XDefaultRootWindow get-dpy dup XDefaultRootWindow
{ int int int int int int int } { int int int int int int int }
[ XQueryPointer drop ] with-out-parameters [ XQueryPointer drop ] with-out-parameters
[ 4 ndrop ] 3dip ; [ 4drop ] 3dip ;
M: gtk-game-input-backend read-mouse M: gtk-game-input-backend read-mouse
query-pointer query-pointer

2
basis/game/input/x11/x11.factor
View File

@ -90,7 +90,7 @@ M: x11-game-input-backend read-keyboard
dpy get dup XDefaultRootWindow dpy get dup XDefaultRootWindow
{ int int int int int int int } { int int int int int int int }
[ XQueryPointer drop ] with-out-parameters [ XQueryPointer drop ] with-out-parameters
[ 4 ndrop ] 3dip ; [ 4drop ] 3dip ;
SYMBOL: mouse-reset? SYMBOL: mouse-reset?

2
basis/grouping/grouping.factor
View File

@ -61,7 +61,7 @@ M: clumps group@
<PRIVATE <PRIVATE
: map-like ( seq n quot -- seq ) : map-like ( seq n quot -- seq )
2keep drop '[ _ like ] map ; inline keepd '[ _ like ] map ; inline
PRIVATE> PRIVATE>

2
basis/heaps/heaps.factor
View File

@ -60,7 +60,7 @@ M: heap heap-size ( heap -- n )
: data-push ( entry data -- n ) : data-push ( entry data -- n )
[ length [ >>index ] keep ] [ length [ >>index ] keep ]
[ [ set-nth ] 2keep drop ] bi ; inline [ [ set-nth ] keepd ] bi ; inline
GENERIC: heap-compare ( entry1 entry2 heap -- ? ) GENERIC: heap-compare ( entry1 entry2 heap -- ? )

1
basis/help/lint/checks/checks.factor
View File

@ -83,6 +83,7 @@ SYMBOL: vocab-articles
] map ; ] map ;
: contains-funky-elements? ( element -- ? ) : contains-funky-elements? ( element -- ? )
B
{ {
$shuffle $shuffle
$complex-shuffle $complex-shuffle

2
basis/inverse/inverse.factor
View File

@ -259,7 +259,7 @@ DEFER: __
: recover-fail ( try fail -- ) : recover-fail ( try fail -- )
[ drop call ] [ [ drop call ] [
[ nip ] dip dup fail? nipd dup fail?
[ drop call ] [ nip throw ] if [ drop call ] [ nip throw ] if
] recover ; inline ] recover ; inline

2
basis/io/backend/unix/multiplexers/epoll/epoll.factor
View File

@ -23,7 +23,7 @@ M: epoll-mx dispose* fd>> close-file ;
: make-event ( fd events -- event ) : make-event ( fd events -- event )
epoll-event <struct> epoll-event <struct>
swap >>events swap >>events
swap over data>> fd<< ; tuck data>> fd<< ;
:: do-epoll-ctl ( fd mx what events -- ) :: do-epoll-ctl ( fd mx what events -- )
mx fd>> what fd fd events make-event epoll_ctl io-error ; mx fd>> what fd fd events make-event epoll_ctl io-error ;

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

@ -56,7 +56,7 @@ TYPED: buffer-read-into ( dst n: fixnum buffer: buffer -- count )
pick c-ptr? [ pick c-ptr? [
memcpy memcpy
] [ ] [
-rot swap spin
[ swap alien-unsigned-1 ] [ swap alien-unsigned-1 ]
[ set-nth-unsafe ] bi-curry* [ set-nth-unsafe ] bi-curry*
[ bi ] 2curry each-integer [ bi ] 2curry each-integer

24
basis/io/encodings/utf32/utf32.factor
View File

@ -20,29 +20,25 @@ utf32 "UTF-32" register-encoding
! Decoding ! Decoding
: char> ( stream encoding quot -- ch ) : char> ( stream quot -- ch )
nip swap 4 swap stream-read dup length { swap [ 4 ] dip stream-read dup length {
{ 0 [ 2drop f ] } { 0 [ 2drop f ] }
{ 4 [ swap call ] } { 4 [ swap call ] }
[ 3drop replacement-char ] [ 3drop replacement-char ]
} case ; inline } case ; inline
M: utf32be decode-char M: utf32be decode-char drop [ be> ] char> ;
[ be> ] char> ;
M: utf32le decode-char M: utf32le decode-char drop [ le> ] char> ;
[ le> ] char> ;
! Encoding ! Encoding
: >char ( char stream encoding quot -- ) : >char ( char stream quot -- )
nip 4 swap curry dip stream-write ; inline 4 swap curry dip stream-write ; inline
M: utf32be encode-char M: utf32be encode-char drop [ >be ] >char ;
[ >be ] >char ;
M: utf32le encode-char M: utf32le encode-char drop [ >le ] >char ;
[ >le ] >char ;
! UTF-32 ! UTF-32
@ -51,7 +47,9 @@ CONSTANT: bom-le B{ 0xff 0xfe 0 0 }
CONSTANT: bom-be B{ 0 0 0xfe 0xff } CONSTANT: bom-be B{ 0 0 0xfe 0xff }
: bom>le/be ( bom -- le/be ) : bom>le/be ( bom -- le/be )
dup bom-le sequence= [ drop utf32le ] [ dup bom-le sequence= [
drop utf32le
] [
bom-be sequence= [ utf32be ] [ missing-bom ] if bom-be sequence= [ utf32be ] [ missing-bom ] if
] if ; ] if ;

2
basis/io/files/windows/windows.factor
View File

@ -388,7 +388,7 @@ M: windows home
FindStreamInfoStandard FindStreamInfoStandard
WIN32_FIND_STREAM_DATA <struct> WIN32_FIND_STREAM_DATA <struct>
0 0
[ FindFirstStream ] 2keep drop [ FindFirstStream ] keepd
over -1 <alien> = [ over -1 <alien> = [
2drop throw-win32-error 2drop throw-win32-error
] [ ] [

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

@ -89,25 +89,25 @@ M: input-port stream-read-unsafe
: read-until-loop ( seps port accum -- sep/f ) : read-until-loop ( seps port accum -- sep/f )
2over read-until-step over [ 2over read-until-step over [
[ append! ] dip dup [ [ append! ] dip dup [
[ 3drop ] dip 3nip
] [ ] [
drop read-until-loop drop read-until-loop
] if ] if
] [ ] [
[ 4drop ] dip 4nip
] if ; inline recursive ] if ; inline recursive
PRIVATE> PRIVATE>
M: input-port stream-read-until M: input-port stream-read-until
2dup read-until-step dup [ 2dup read-until-step dup [
[ 2drop ] 2dip 2nipd
] [ ] [
over [ over [
drop drop
BV{ } like [ read-until-loop ] keep B{ } like swap BV{ } like [ read-until-loop ] keep B{ } like swap
] [ ] [
[ 2drop ] 2dip 2nipd
] if ] if
] if ; ] if ;

2
basis/io/sockets/secure/openssl/openssl.factor
View File

@ -238,7 +238,7 @@ SYMBOL: default-secure-context
] [ nip (ssl-error) ] if-zero ; ] [ nip (ssl-error) ] if-zero ;
: check-ssl-error ( ssl ret exra-cases/f -- event/f ) : check-ssl-error ( ssl ret exra-cases/f -- event/f )
[ swap over SSL_get_error ] dip [ tuck SSL_get_error ] dip
{ {
{ SSL_ERROR_NONE [ drop f ] } { SSL_ERROR_NONE [ drop f ] }
{ SSL_ERROR_WANT_READ [ drop +input+ ] } { SSL_ERROR_WANT_READ [ drop +input+ ] }

8
basis/io/sockets/unix/unix.factor
View File

@ -40,11 +40,11 @@ M: unix addrspec-of-family
! Client sockets - TCP and Unix domain ! Client sockets - TCP and Unix domain
M: object (get-local-address) M: object (get-local-address)
[ handle-fd ] dip empty-sockaddr/size int <ref> [ handle-fd ] dip empty-sockaddr/size int <ref>
[ getsockname io-error ] 2keep drop ; [ getsockname io-error ] keepd ;
M: object (get-remote-address) M: object (get-remote-address)
[ handle-fd ] dip empty-sockaddr/size int <ref> [ handle-fd ] dip empty-sockaddr/size int <ref>
[ getpeername io-error ] 2keep drop ; [ getpeername io-error ] keepd ;
: init-client-socket ( fd -- ) : init-client-socket ( fd -- )
SOL_SOCKET SO_OOBINLINE set-socket-option ; SOL_SOCKET SO_OOBINLINE set-socket-option ;
@ -94,7 +94,7 @@ M: object (server)
: do-accept ( server addrspec -- fd sockaddr ) : do-accept ( server addrspec -- fd sockaddr )
[ handle>> handle-fd ] [ empty-sockaddr/size int <ref> ] bi* [ handle>> handle-fd ] [ empty-sockaddr/size int <ref> ] bi*
[ unix.ffi:accept ] 2keep drop ; inline [ unix.ffi:accept ] keepd ; inline
M: object (accept) M: object (accept)
2dup do-accept over 0 >= [ 2dup do-accept over 0 >= [
@ -133,7 +133,7 @@ M: unix (broadcast)
recvfrom sockaddr ; inline recvfrom sockaddr ; inline
: (receive-loop) ( n buf datagram -- count sockaddr ) : (receive-loop) ( n buf datagram -- count sockaddr )
3dup do-receive over 0 > [ [ 3drop ] 2dip ] [ 3dup do-receive over 0 > [ 3nipd ] [
2drop [ +input+ wait-for-port ] [ (receive-loop) ] bi 2drop [ +input+ wait-for-port ] [ (receive-loop) ] bi
] if ; inline recursive ] if ; inline recursive

4
basis/io/sockets/windows/windows.factor
View File

@ -56,11 +56,11 @@ M: win32-socket dispose* ( stream -- )
M: object (get-local-address) ( socket addrspec -- sockaddr ) M: object (get-local-address) ( socket addrspec -- sockaddr )
[ handle>> ] dip empty-sockaddr/size int <ref> [ handle>> ] dip empty-sockaddr/size int <ref>
[ getsockname socket-error ] 2keep drop ; [ getsockname socket-error ] keepd ;
M: object (get-remote-address) ( socket addrspec -- sockaddr ) M: object (get-remote-address) ( socket addrspec -- sockaddr )
[ handle>> ] dip empty-sockaddr/size int <ref> [ handle>> ] dip empty-sockaddr/size int <ref>
[ getpeername socket-error ] 2keep drop ; [ getpeername socket-error ] keepd ;
: bind-socket ( win32-socket sockaddr len -- ) : bind-socket ( win32-socket sockaddr len -- )
[ handle>> ] 2dip bind socket-error ; [ handle>> ] 2dip bind socket-error ;

2
basis/libc/macosx/macosx.factor
View File

@ -145,6 +145,6 @@ FUNCTION: int strerror_r ( int errno, char* buf, size_t buflen )
M: macosx strerror ( errno -- str ) M: macosx strerror ( errno -- str )
[ [
1024 [ malloc &free ] keep [ strerror_r ] 2keep drop nip 1024 [ malloc &free ] keep [ strerror_r ] keepd nip
alien>native-string alien>native-string
] with-destructors ; ] with-destructors ;

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

@ -111,6 +111,6 @@ FUNCTION: int strerror_s ( char *buffer, size_t numberOfElements, int errnum )
M: windows strerror ( errno -- str ) M: windows strerror ( errno -- str )
[ [
[ 1024 [ malloc &free ] keep ] dip [ 1024 [ malloc &free ] keep ] dip
[ strerror_s drop ] 3keep 2drop [ strerror_s drop ] keepdd
utf8 alien>string utf8 alien>string
] with-destructors ; ] with-destructors ;

2
basis/logging/logging.factor
View File

@ -134,7 +134,7 @@ PRIVATE>
'[ _ [ _ log-error @ ] recover ] ; '[ _ [ _ log-error @ ] recover ] ;
: add-error-logging ( word level -- ) : add-error-logging ( word level -- )
[ [ input-logging-quot ] 2keep drop error-logging-quot ] [ [ input-logging-quot ] keepd error-logging-quot ]
(define-logging) ; (define-logging) ;
SYNTAX: LOG: SYNTAX: LOG:

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

@ -244,7 +244,7 @@ PRIVATE>
[ drop pick [ combination ] [ 3drop f ] if ] 3bi ; inline [ drop pick [ combination ] [ 3drop f ] if ] 3bi ; inline
: reduce-combinations ( ... seq k identity quot: ( ... prev elt -- ... next ) -- ... result ) : reduce-combinations ( ... seq k identity quot: ( ... prev elt -- ... next ) -- ... result )
[ -rot ] dip each-combination ; inline -rotd each-combination ; inline
: all-subsets ( seq -- subsets ) : all-subsets ( seq -- subsets )
dup length [0,b] [ all-combinations ] with map concat ; dup length [0,b] [ all-combinations ] with map concat ;

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

@ -359,7 +359,7 @@ M: float truncate
dup -52 shift 0x7ff bitand 0x3ff - dup -52 shift 0x7ff bitand 0x3ff -
! check for floats without fractional part (>= 2^52) ! check for floats without fractional part (>= 2^52)
dup 52 < [ dup 52 < [
[ drop ] 2dip nipd
dup 0 < [ dup 0 < [
! the float is between -1.0 and 1.0, ! the float is between -1.0 and 1.0,
! the result could be +/-0.0, but we will ! the result could be +/-0.0, but we will

2
basis/math/matrices/elimination/elimination.factor
View File

@ -28,7 +28,7 @@ SYMBOL: matrix
0 swap nth-row [ zero? not ] skip ; 0 swap nth-row [ zero? not ] skip ;
: clear-scale ( col# pivot-row i-row -- n ) : clear-scale ( col# pivot-row i-row -- n )
[ over ] dip nth dup zero? [ overd nth dup zero? [
3drop 0 3drop 0
] [ ] [
[ nth dup zero? ] dip swap [ [ nth dup zero? ] dip swap [

2
basis/math/partial-dispatch/partial-dispatch.factor
View File

@ -143,7 +143,7 @@ SYMBOL: fast-math-ops
: math-method* ( word left right -- quot ) : math-method* ( word left right -- quot )
3dup math-op 3dup math-op
[ [ 3drop ] dip 1quotation ] [ drop math-method ] if ; [ 3nip 1quotation ] [ drop math-method ] if ;
: math-both-known? ( word left right -- ? ) : math-both-known? ( word left right -- ? )
3dup math-op 3dup math-op

4
basis/math/statistics/statistics.factor
View File

@ -269,7 +269,7 @@ ALIAS: std sample-std
<PRIVATE <PRIVATE
: r-sum-diffs ( x-mean y-mean x-seq y-seq -- (r) ) : r-sum-diffs ( x-mean y-mean x-seq y-seq -- (r) )
! finds sigma((xi-mean(x))(yi-mean(y)) ! finds sigma((xi-mean(x))(yi-mean(y))
0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ; 0 [ [ reach - ] bi@ * + ] 2reduce 2nip ;
: (r) ( x-mean y-mean x-seq y-seq x-std y-std -- r ) : (r) ( x-mean y-mean x-seq y-seq x-std y-std -- r )
* recip [ [ r-sum-diffs ] keep length 1 - / ] dip * ; * recip [ [ r-sum-diffs ] keep length 1 - / ] dip * ;
@ -281,7 +281,7 @@ PRIVATE>
: pearson-r ( xy-pairs -- r ) r-stats (r) ; : pearson-r ( xy-pairs -- r ) r-stats (r) ;
: least-squares ( xy-pairs -- alpha beta ) : least-squares ( xy-pairs -- alpha beta )
r-stats [ 2dup ] 4 ndip r-stats [ 2dup ] 4dip
! stack is x-mean y-mean x-mean y-mean x-seq y-seq x-std y-std ! stack is x-mean y-mean x-mean y-mean x-seq y-seq x-std y-std
[ (r) ] 2keep ! stack is mean(x) mean(y) r sx sy [ (r) ] 2keep ! stack is mean(x) mean(y) r sx sy
swap / * ! stack is mean(x) mean(y) beta swap / * ! stack is mean(x) mean(y) beta

6
basis/math/vectors/simd/intrinsics/intrinsics.factor
View File

@ -268,16 +268,16 @@ PRIVATE>
: (simd-vunpack-tail) ( a rep -- c ) : (simd-vunpack-tail) ( a rep -- c )
[ byte>rep-array ] [ widen-vector-rep [ rep-length ] [ '[ _ >rep-array ] ] bi ] bi [ byte>rep-array ] [ widen-vector-rep [ rep-length ] [ '[ _ >rep-array ] ] bi ] bi
[ tail-slice ] dip call( a' -- c' ) underlying>> ; [ tail-slice ] dip call( a' -- c' ) underlying>> ;
: (simd-with) ( n rep -- v ) : (simd-with) ( n rep -- v )
[ rep-length swap '[ _ ] ] [ <rep-array> ] bi replicate-as [ rep-length swap '[ _ ] ] [ <rep-array> ] bi replicate-as
underlying>> ; underlying>> ;
: (simd-gather-2) ( m n rep -- v ) <rep-array> [ 2 set-firstn-unsafe ] keep underlying>> ; : (simd-gather-2) ( m n rep -- v ) <rep-array> [ 2 set-firstn-unsafe ] keep underlying>> ;
: (simd-gather-4) ( m n o p rep -- v ) <rep-array> [ 4 set-firstn-unsafe ] keep underlying>> ; : (simd-gather-4) ( m n o p rep -- v ) <rep-array> [ 4 set-firstn-unsafe ] keep underlying>> ;
: (simd-select) ( a n rep -- x ) swapd byte>rep-array nth-unsafe ; : (simd-select) ( a n rep -- x ) swapd byte>rep-array nth-unsafe ;
: alien-vector ( c-ptr n rep -- value ) : alien-vector ( c-ptr n rep -- value )
[ swap <displaced-alien> ] dip rep-size memory>byte-array ; [ swap <displaced-alien> ] dip rep-size memory>byte-array ;
: set-alien-vector ( value c-ptr n rep -- ) : set-alien-vector ( value c-ptr n rep -- )
[ swap <displaced-alien> swap ] dip rep-size memcpy ; [ swap <displaced-alien> swap ] dip rep-size memcpy ;
"compiler.cfg.intrinsics.simd" require "compiler.cfg.intrinsics.simd" require

2
basis/opengl/shaders/shaders.factor
View File

@ -66,7 +66,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
: (gl-program) ( shaders quot: ( gl-program -- ) -- program ) : (gl-program) ( shaders quot: ( gl-program -- ) -- program )
glCreateProgram glCreateProgram
[ [
rot dupd attach-shaders swap call dup roll attach-shaders swap call
] [ glLinkProgram ] [ ] tri gl-error ; inline ] [ glLinkProgram ] [ ] tri gl-error ; inline
: <gl-program> ( shaders -- program ) : <gl-program> ( shaders -- program )

2
basis/opengl/textures/textures.factor
View File

@ -290,7 +290,7 @@ TUPLE: single-texture < disposable image dim loc texture-coords texture display-
: tex-sub-image ( image -- ) : tex-sub-image ( image -- )
[ GL_TEXTURE_2D 0 0 0 ] dip [ GL_TEXTURE_2D 0 0 0 ] dip
[ dim>> first2 ] [ dim>> first2 ]
[ image-format [ drop ] 2dip ] [ image-format nipd ]
[ bitmap>> ] tri [ bitmap>> ] tri
glTexSubImage2D ; glTexSubImage2D ;

6
basis/peg/peg.factor
View File

@ -37,7 +37,7 @@ SYMBOL: error-stack
: merge-errors ( -- ) : merge-errors ( -- )
error-stack get dup length 1 > [ error-stack get dup length 1 > [
dup pop over pop swap (merge-errors) swap push [ pop ] [ pop swap (merge-errors) ] [ ] tri push
] [ ] [
drop drop
] if ; ] if ;
@ -144,7 +144,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
[ [ setup-growth ] 2keep ] 2dip [ [ setup-growth ] 2keep ] 2dip
[ dup eval-rule ] dip swap [ dup eval-rule ] dip swap
dup pick stop-growth? [ dup pick stop-growth? [
5 ndrop 5drop
] [ ] [
over update-m over update-m
(grow-lr) (grow-lr)
@ -347,7 +347,7 @@ TUPLE: satisfy-parser quot ;
swap [ swap [
drop f drop f
] [ ] [
unclip-slice rot dupd call [ unclip-slice dup roll call [
<parse-result> <parse-result>
] [ ] [
2drop f 2drop f

2
basis/persistent/vectors/vectors.factor
View File

@ -95,7 +95,7 @@ M: persistent-vector ppush ( val pvec -- pvec' )
: node-change-nth ( i node quot -- node' ) : node-change-nth ( i node quot -- node' )
[ clone ] dip [ [ clone ] dip [
[ clone ] dip [ change-nth ] 2keep drop [ clone ] dip [ change-nth ] keepd
] curry change-children ; inline ] curry change-children ; inline
: (new-nth) ( val i node -- node' ) : (new-nth) ( val i node -- node' )

4
basis/regexp/regexp.factor
View File

@ -60,7 +60,7 @@ PRIVATE>
:: next-match ( i string regexp quot: ( i string regexp -- j ) reverse? -- start end ? ) :: next-match ( i string regexp quot: ( i string regexp -- j ) reverse? -- start end ? )
f f f f f f
i string reverse? search-range i string reverse? search-range
[ [ 3drop ] dip string regexp quot reverse? (next-match) dup ] find 2drop ; inline [ 3nip string regexp quot reverse? (next-match) dup ] find 2drop ; inline
: do-next-match ( i string regexp -- start end ? ) : do-next-match ( i string regexp -- start end ? )
dup next-match>> dup next-match>>
@ -130,7 +130,7 @@ PRIVATE>
] [ 2drop f ] if ; ] [ 2drop f ] if ;
: re-contains? ( string regexp -- ? ) : re-contains? ( string regexp -- ? )
prepare-match-iterator do-next-match [ 2drop ] dip >boolean ; prepare-match-iterator do-next-match 2nip >boolean ;
: re-split ( string regexp -- seq ) : re-split ( string regexp -- seq )
[ <slice-unsafe> ] (re-split) ; [ <slice-unsafe> ] (re-split) ;

6
basis/sequences/generalizations/generalizations-tests.factor
View File

@ -36,12 +36,10 @@ IN: sequences.generalizations.tests
[ 4 nappend print ] 4 0 mnmap ; [ 4 nappend print ] 4 0 mnmap ;
: nproduce-as-test ( n -- a b ) : nproduce-as-test ( n -- a b )
[ dup zero? not ] [ dup zero? not ]
[ [ 2 - ] [ ] [ 1 - ] tri ] { } B{ } 2 nproduce-as [ [ 2 - ] [ ] [ 1 - ] tri ] { } B{ } 2 nproduce-as nipd ;
[ drop ] 2dip ;
: nproduce-test ( n -- a b ) : nproduce-test ( n -- a b )
[ dup zero? not ] [ dup zero? not ]
[ [ 2 - ] [ ] [ 1 - ] tri ] 2 nproduce [ [ 2 - ] [ ] [ 1 - ] tri ] 2 nproduce nipd ;
[ drop ] 2dip ;
{ "A1a! { "A1a!
B2b@ B2b@

2
basis/sequences/generalizations/generalizations.factor
View File

@ -117,7 +117,7 @@ MACRO: (ncollect) ( n -- quot )
[ { } swap dupn ] keep nproduce-as ; inline [ { } swap dupn ] keep nproduce-as ; inline
MACRO: nmap-reduce ( map-quot reduce-quot n -- quot ) MACRO: nmap-reduce ( map-quot reduce-quot n -- quot )
-rot dupd compose [ over ] dip over '[ -rot dupd compose overd over '[
[ [ first ] _ napply @ 1 ] _ nkeep [ [ first ] _ napply @ 1 ] _ nkeep
_ _ (neach) (each-integer) _ _ (neach) (each-integer)
] ; ] ;

4
basis/sequences/merged/merged.factor
View File

@ -14,10 +14,10 @@ C: <merged> merged
[ <merged> ] keep first like ; [ <merged> ] keep first like ;
: 2merge ( seq1 seq2 -- seq ) : 2merge ( seq1 seq2 -- seq )
[ <2merged> ] 2keep drop like ; [ <2merged> ] keepd like ;
: 3merge ( seq1 seq2 seq3 -- seq ) : 3merge ( seq1 seq2 seq3 -- seq )
[ <3merged> ] 3keep 2drop like ; [ <3merged> ] keepdd like ;
M: merged length M: merged length
seqs>> [ [ length ] [ min ] map-reduce ] [ length ] bi * ; inline seqs>> [ [ length ] [ min ] map-reduce ] [ length ] bi * ; inline

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

@ -62,7 +62,7 @@ TUPLE: sequence-parser sequence n ;
: <safe-slice> ( from to seq -- slice/f ) : <safe-slice> ( from to seq -- slice/f )
3dup { 3dup {
[ 2drop 0 < ] [ 2drop 0 < ]
[ [ drop ] 2dip length > ] [ nipd length > ]
[ drop > ] [ drop > ]
} 3|| [ 3drop f ] [ <slice-unsafe> ] if ; inline } 3|| [ 3drop f ] [ <slice-unsafe> ] if ; inline

6
basis/sequences/unrolled/unrolled.factor
View File

@ -25,7 +25,7 @@ PRIVATE>
(unrolled-collect) unrolled-each-integer ; inline (unrolled-collect) unrolled-each-integer ; inline
: unrolled-map-integers ( n quot: ( n -- value ) exemplar -- newseq ) : unrolled-map-integers ( n quot: ( n -- value ) exemplar -- newseq )
[ over ] dip [ [ unrolled-collect ] keep ] new-like ; inline overd [ [ unrolled-collect ] keep ] new-like ; inline
ERROR: unrolled-bounds-error ERROR: unrolled-bounds-error
seq unroll-length ; seq unroll-length ;
@ -70,7 +70,7 @@ ERROR: unrolled-2bounds-error
pick unrolled-map-as-unsafe ; inline pick unrolled-map-as-unsafe ; inline
: unrolled-2map-unsafe ( xseq yseq len quot: ( x y -- newx ) -- newseq ) : unrolled-2map-unsafe ( xseq yseq len quot: ( x y -- newx ) -- newseq )
4 npick unrolled-2map-as-unsafe ; inline reach unrolled-2map-as-unsafe ; inline
PRIVATE> PRIVATE>
@ -93,7 +93,7 @@ PRIVATE>
pick unrolled-map-as ; inline pick unrolled-map-as ; inline
: unrolled-2map ( xseq yseq len quot: ( x y -- newx ) -- newseq ) : unrolled-2map ( xseq yseq len quot: ( x y -- newx ) -- newseq )
4 npick unrolled-2map-as ; inline reach unrolled-2map-as ; inline
: unrolled-map-index ( seq len quot: ( x i -- newx ) -- newseq ) : unrolled-map-index ( seq len quot: ( x i -- newx ) -- newseq )
[ dup length <iota> ] 2dip unrolled-2map ; inline [ dup length <iota> ] 2dip unrolled-2map ; inline

2
basis/sequences/windowed/windowed.factor
View File

@ -22,7 +22,7 @@ M: windowed-sequence length
[ drop 0 ] [ length ] bi clamp ; inline [ drop 0 ] [ length ] bi clamp ; inline
: in-bounds ( a b sequence -- a' b' sequence ) : in-bounds ( a b sequence -- a' b' sequence )
[ nip in-bound ] [ [ nip ] dip in-bound ] [ 2nip ] 3tri ; [ nip in-bound ] [ nipd in-bound ] [ 2nip ] 3tri ;
:: rolling-map ( ... seq n quot: ( ... slice -- ... elt ) -- ... newseq ) :: rolling-map ( ... seq n quot: ( ... slice -- ... elt ) -- ... newseq )
seq length [ seq length [

7
basis/shuffle/shuffle-docs.factor
View File

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

3
basis/shuffle/shuffle-tests.factor
View File

@ -3,6 +3,3 @@ USING: shuffle tools.test ;
{ 1 2 3 4 } [ 3 4 1 2 2swap ] unit-test { 1 2 3 4 } [ 3 4 1 2 2swap ] unit-test
{ 4 2 3 } [ 1 2 3 4 shuffle( a b c d -- d b c ) ] unit-test { 4 2 3 } [ 1 2 3 4 shuffle( a b c d -- d b c ) ] unit-test
{ 2 3 4 1 } [ 1 2 3 4 roll ] unit-test
{ 1 2 3 4 } [ 2 3 4 1 -roll ] unit-test

6
basis/shuffle/shuffle.factor
View File

@ -14,12 +14,6 @@ MACRO: shuffle-effect ( effect -- quot )
SYNTAX: shuffle( SYNTAX: shuffle(
")" parse-effect suffix! \ shuffle-effect suffix! ; ")" 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 : 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
: 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline : 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline

45
basis/stack-checker/known-words/known-words.factor
View File

@ -61,23 +61,34 @@ IN: stack-checker.known-words
} cond ; } cond ;
{ {
{ drop ( x -- ) } { drop ( x -- ) }
{ 2drop ( x y -- ) } { 2drop ( x y -- ) }
{ 3drop ( x y z -- ) } { 3drop ( x y z -- ) }
{ 4drop ( w x y z -- ) } { 4drop ( w x y z -- ) }
{ dup ( x -- x x ) } { dup ( x -- x x ) }
{ 2dup ( x y -- x y x y ) } { 2dup ( x y -- x y x y ) }
{ 3dup ( x y z -- x y z x y z ) } { 3dup ( x y z -- x y z x y z ) }
{ 4dup ( w x y z -- w x y z w x y z ) } { 4dup ( w x y z -- w x y z w x y z ) }
{ rot ( x y z -- y z x ) } { rot ( x y z -- y z x ) }
{ -rot ( x y z -- z x y ) } { -rot ( x y z -- z x y ) }
{ dupd ( x y -- x x y ) } { roll ( w x y z -- x y z w ) }
{ swapd ( x y z -- y x z ) } { -roll ( w x y z -- z w x y ) }
{ nip ( x y -- y ) } { reach ( w x y z -- w x y z w ) }
{ 2nip ( x y z -- z ) } { dupd ( x y -- x x y ) }
{ over ( x y -- x y x ) } { swapd ( x y z -- y x z ) }
{ pick ( x y z -- x y z x ) } { nip ( x y -- y ) }
{ swap ( x y -- y x ) } { 2nip ( x y z -- z ) }
{ 3nip ( w x y z -- z ) }
{ 4nip ( v w x y z -- z ) }
{ nipd ( x y z -- y z ) }
{ 2nipd ( w x y z -- y z ) }
{ 3nipd ( v w x y z -- y z ) }
{ over ( x y -- x y x ) }
{ overd ( x y z -- x y x z ) }
{ pick ( x y z -- x y z x ) }
{ pickd ( w x y z -- w x y w z ) }
{ swap ( x y -- y x ) }
{ tuck ( x y -- y x y ) }
} [ "shuffle" set-word-prop ] assoc-each } [ "shuffle" set-word-prop ] assoc-each
: check-declaration ( declaration -- declaration ) : check-declaration ( declaration -- declaration )

2
basis/stack-checker/stack-checker-tests.factor
View File

@ -453,7 +453,7 @@ DEFER: eee'
! ensure that polymorphic checking works on recursive combinators ! ensure that polymorphic checking works on recursive combinators
: (recursive-reduce) ( identity i seq quot: ( prev elt -- next ) n -- result ) : (recursive-reduce) ( identity i seq quot: ( prev elt -- next ) n -- result )
[ pick ] dip swap over < [ pickd tuck < [
[ [ [ nth-unsafe ] dip call ] 3keep [ 1 + ] 2dip ] dip [ [ [ nth-unsafe ] dip call ] 3keep [ 1 + ] 2dip ] dip
(recursive-reduce) (recursive-reduce)
] [ 4drop ] if ; inline recursive ] [ 4drop ] if ; inline recursive

2
basis/tools/deploy/backend/backend.factor
View File

@ -20,7 +20,7 @@ ERROR: can't-deploy-library-file library ;
: copy-library ( dir library -- ) : copy-library ( dir library -- )
dup find-library-file dup find-library-file
[ swap over file-name append-path copy-file ] [ tuck file-name append-path copy-file ]
[ can't-deploy-library-file ] ?if ; [ can't-deploy-library-file ] ?if ;
: copy-libraries ( manifest name dir -- ) : copy-libraries ( manifest name dir -- )

2
basis/ui/backend/windows/windows.factor
View File

@ -458,7 +458,7 @@ SYMBOL: nc-buttons
: handle-wm-buttonup ( hWnd uMsg wParam lParam -- ) : handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
mouse-captured get [ release-capture ] when mouse-captured get [ release-capture ] when
pick message>button drop dup nc-buttons get member? [ pick message>button drop dup nc-buttons get member? [
nc-buttons get remove! drop 4drop nc-buttons get remove! 5drop
] [ ] [
drop prepare-mouse send-button-up drop prepare-mouse send-button-up
] if ; ] if ;

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

@ -137,7 +137,7 @@ DEFER: compose-iter
: try-noncombining ( state char -- state ) : try-noncombining ( state char -- state )
[ drop ] [ [ char>> ] dip combine-chars ] 2bi [ drop ] [ [ char>> ] dip combine-chars ] 2bi
[ >>char to f >>last-class compose-iter ] when* ; inline [ >>char to f >>last-class compose-iter ] when* ; inline recursive
: compose-iter ( state -- state ) : compose-iter ( state -- state )
dup current [ dup current [

2
basis/windows/directx/dinput/constants/constants.factor
View File

@ -71,7 +71,7 @@ M: array array-base-type first ;
>> >>
MACRO: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien ) MACRO: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
[ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip [ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4dip
[ nip length ] [ make-DIOBJECTDATAFORMAT-array-quot ] 2bi [ nip length ] [ make-DIOBJECTDATAFORMAT-array-quot ] 2bi
'[ _ _ _ _ _ @ DIDATAFORMAT <struct-boa> ] ; '[ _ _ _ _ _ @ DIDATAFORMAT <struct-boa> ] ;

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

@ -387,7 +387,7 @@ FUNCTION: DWORD GetNetworkParams ( PFIXED_INFO pFixedInfo, PULONG pOutBufLen )
: get-fixed-info ( -- FIXED_INFO ) : get-fixed-info ( -- FIXED_INFO )
FIXED_INFO <struct> dup byte-length ulong <ref> FIXED_INFO <struct> dup byte-length ulong <ref>
[ GetNetworkParams n>win32-error-check ] 2keep drop ; [ GetNetworkParams n>win32-error-check ] keepd ;
: dns-server-ips ( -- sequence ) : dns-server-ips ( -- sequence )
get-fixed-info DnsServerList>> [ get-fixed-info DnsServerList>> [

2
basis/xml/tokenize/tokenize.factor
View File

@ -87,7 +87,7 @@ HINTS: next* { spot } ;
[ blank? not ] skip-until ; [ blank? not ] skip-until ;
: next-matching ( pos ch str -- pos' ) : next-matching ( pos ch str -- pos' )
[ over ] dip nth eq? [ 1 + ] [ drop 0 ] if ; inline overd nth eq? [ 1 + ] [ drop 0 ] if ; inline
: string-matcher ( str -- quot: ( pos char -- pos ? ) ) : string-matcher ( str -- quot: ( pos char -- pos ? ) )
dup length 1 - '[ _ next-matching dup _ > ] ; inline dup length 1 - '[ _ next-matching dup _ > ] ; inline

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

@ -117,7 +117,7 @@ DEFER: finalize-rule-set
[ file-name ] dip [ file-name ] dip
modes modes
[ nip [ 2dup ] dip suitable-mode? ] assoc-find [ nip [ 2dup ] dip suitable-mode? ] assoc-find
2drop [ 2drop ] dip ; 2drop 2nip ;
: find-mode ( file-name first-line -- mode ) : find-mode ( file-name first-line -- mode )
?find-mode "text" or ; inline ?find-mode "text" or ; inline

2
core/alien/strings/strings.factor
View File

@ -38,7 +38,7 @@ M: c-ptr string>alien drop ;
drop [ length ] keep over [ drop [ length ] keep over [
1 + (byte-array) [ 1 + (byte-array) [
[ [
[ [ string-nth-fast ] 2keep drop ] [ [ string-nth-fast ] keepd ]
[ set-nth-unsafe ] bi* [ set-nth-unsafe ] bi*
] 2curry each-integer ] 2curry each-integer
] keep ] keep

4
core/assocs/assocs.factor
View File

@ -37,7 +37,7 @@ M: assoc assoc-like drop ; inline
3drop f 3drop f
] [ ] [
3dup nth-unsafe at* 3dup nth-unsafe at*
[ [ 3drop ] dip ] [ drop [ 1 - ] dip (assoc-stack) ] if [ 3nip ] [ drop [ 1 - ] dip (assoc-stack) ] if
] if ; inline recursive ] if ; inline recursive
: search-alist ( key alist -- pair/f i/f ) : search-alist ( key alist -- pair/f i/f )
@ -156,7 +156,7 @@ M: assoc values [ nip ] { } assoc>map ;
over [ set-at ] with-assoc assoc-each ; over [ set-at ] with-assoc assoc-each ;
: assoc-union-as ( assoc1 assoc2 exemplar -- union ) : assoc-union-as ( assoc1 assoc2 exemplar -- union )
[ [ [ assoc-size ] bi@ + ] dip new-assoc ] 3keep drop [ [ [ assoc-size ] bi@ + ] dip new-assoc ] 2keepd
[ assoc-union! ] bi@ ; [ assoc-union! ] bi@ ;
: assoc-union ( assoc1 assoc2 -- union ) : assoc-union ( assoc1 assoc2 -- union )

2
core/classes/tuple/parser/parser.factor
View File

@ -97,7 +97,7 @@ M: tuple-class boa>object
swap slots>tuple ; swap slots>tuple ;
: check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index ) : check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index )
over [ drop ] [ nip nip nip bad-slot-name ] if ; over [ drop ] [ 3nip bad-slot-name ] if ;
: slot-named-checked ( class initials name slots -- class initials slot-spec ) : slot-named-checked ( class initials name slots -- class initials slot-spec )
over [ slot-named* ] dip check-slot-exists drop ; over [ slot-named* ] dip check-slot-exists drop ;

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

@ -208,7 +208,7 @@ M: object final-class? drop f ;
pick [ pick [
[ [ swap nth dup ] dip instance? ] dip swap [ [ swap nth dup ] dip instance? ] dip swap
[ drop ] [ nip ] if [ drop ] [ nip ] if
] [ [ 3drop ] dip ] if ; ] [ 3nip ] if ;
: apply-slot-permutation ( old-values triples -- new-values ) : apply-slot-permutation ( old-values triples -- new-values )
[ first3 update-slot ] with map ; [ first3 update-slot ] with map ;

2
core/effects/effects.factor
View File

@ -21,7 +21,7 @@ TUPLE: effect
f f effect boa ; inline f f effect boa ; inline
: <variable-effect> ( in-var in out-var out -- effect ) : <variable-effect> ( in-var in out-var out -- effect )
swap [ rot ] dip [ ?terminated ] 2dip effect boa ; swap rotd [ ?terminated ] 2dip effect boa ;
: effect-height ( effect -- n ) : effect-height ( effect -- n )
[ out>> length ] [ in>> length ] bi - ; inline [ out>> length ] [ in>> length ] bi - ; inline

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

@ -45,7 +45,7 @@ PRIVATE>
{ [ effect-closer? ] [ stack-effect-omits-dashes ] } { [ effect-closer? ] [ stack-effect-omits-dashes ] }
{ [ row-variable? ] [ parse-effect-var t ] } { [ row-variable? ] [ parse-effect-var t ] }
[ [
[ drop ] 2dip standalone-type? nipd standalone-type?
[ parse-standalone-type ] [ parse-effect-value ] if , t [ parse-standalone-type ] [ parse-effect-value ] if , t
] ]
} cond ; } cond ;

2
core/generic/generic.factor
View File

@ -191,7 +191,7 @@ GENERIC#: check-combination-effect 1 ( combination effect -- )
M: object check-combination-effect 2drop ; M: object check-combination-effect 2drop ;
: define-generic ( word combination effect -- ) : define-generic ( word combination effect -- )
[ [ check-combination-effect ] keep swap set-stack-effect ] [ [ check-combination-effect ] keep set-stack-effect ]
[ [
drop drop
2dup [ "combination" word-prop ] dip = [ 2drop ] [ 2dup [ "combination" word-prop ] dip = [ 2drop ] [

2
core/growable/growable.factor
View File

@ -20,7 +20,7 @@ M: growable set-nth-unsafe underlying>> set-nth-unsafe ; inline
[ set-nth-unsafe ] [ [ 1 fixnum+fast ] dip length<< ] 2bi ; inline [ set-nth-unsafe ] [ [ 1 fixnum+fast ] dip length<< ] 2bi ; inline
: push-all-unsafe ( from to src dst -- ) : push-all-unsafe ( from to src dst -- )
[ over - swap ] 2dip [ pick ] dip [ length integer>fixnum ] keep [ over - swap ] 2dip pickd [ length integer>fixnum ] keep
[ [ fixnum+fast ] dip length<< ] 2keep <copy> (copy) drop ; inline [ [ fixnum+fast ] dip length<< ] 2keep <copy> (copy) drop ; inline
PRIVATE> PRIVATE>

4
core/hash-sets/hash-sets.factor
View File

@ -49,7 +49,7 @@ TUPLE: hash-set
[ pick or [ probe ] dip (new-key@) ] [ pick or [ probe ] dip (new-key@) ]
if if
] [ ] [
[ [ pick ] dip = ] 2dip rot [ pickd = ] 2dip rot
[ nip [ drop ] 3dip f ] [ nip [ drop ] 3dip f ]
[ [ probe ] dip (new-key@) ] [ [ probe ] dip (new-key@) ]
if if
@ -125,7 +125,7 @@ M: hash-set ?adjoin
M: hash-set members M: hash-set members
[ array>> 0 swap ] [ cardinality f <array> ] bi [ [ array>> 0 swap ] [ cardinality f <array> ] bi [
[ [ over ] dip set-nth-unsafe 1 + ] curry each-member [ overd set-nth-unsafe 1 + ] curry each-member
] keep nip ; ] keep nip ;
M: hash-set clone M: hash-set clone

4
core/hashtables/hashtables.factor
View File

@ -73,7 +73,7 @@ TUPLE: hashtable
[ pick or [ probe ] dip (new-key@) ] [ pick or [ probe ] dip (new-key@) ]
if if
] [ ] [
[ [ pick ] dip = ] 2dip rot [ pickd = ] 2dip rot
[ nip [ drop ] 3dip f ] [ nip [ drop ] 3dip f ]
[ [ probe ] dip (new-key@) ] [ [ probe ] dip (new-key@) ]
if if
@ -154,7 +154,7 @@ M: hashtable set-at
: collect-pairs ( hash quot: ( key value -- elt ) -- seq ) : collect-pairs ( hash quot: ( key value -- elt ) -- seq )
[ [ array>> 0 swap ] [ assoc-size f <array> ] bi ] dip swap [ [ [ array>> 0 swap ] [ assoc-size f <array> ] bi ] dip swap [
[ [ over ] dip set-nth-unsafe 1 + ] curry compose each-pair [ overd set-nth-unsafe 1 + ] curry compose each-pair
] keep nip ; inline ] keep nip ; inline
PRIVATE> PRIVATE>

15
core/io/encodings/encodings.factor
View File

@ -44,7 +44,7 @@ CONSTANT: replacement-char 0xfffd
{ string } declare ! aux>> must be f { string } declare ! aux>> must be f
[ length ] keep over (byte-array) [ [ length ] keep over (byte-array) [
[ [
[ [ string-nth-fast ] 2keep drop ] [ [ string-nth-fast ] keepd ]
[ set-nth-unsafe ] bi* [ set-nth-unsafe ] bi*
] 2curry each-integer ] 2curry each-integer
] keep ; inline ] keep ; inline
@ -53,7 +53,7 @@ CONSTANT: replacement-char 0xfffd
{ byte-array } declare { byte-array } declare
[ length ] keep over 0 <string> [ [ length ] keep over 0 <string> [
[ [
[ [ nth-unsafe ] 2keep drop ] [ [ nth-unsafe ] keepd ]
[ [
pick 127 <= pick 127 <=
[ set-string-nth-fast ] [ set-string-nth-fast ]
@ -119,17 +119,14 @@ M: decoder stream-read1 ( decoder -- ch )
: (store-read) ( buf stream encoding n c i -- buf stream encoding n ) : (store-read) ( buf stream encoding n c i -- buf stream encoding n )
[ rot [ set-nth-unsafe ] keep ] 2curry 3dip ; inline [ rot [ set-nth-unsafe ] keep ] 2curry 3dip ; inline
: (finish-read) ( buf stream encoding n i -- i )
2nip 2nip ; inline
: (read-next) ( stream encoding n i -- stream encoding n i c ) : (read-next) ( stream encoding n i -- stream encoding n i c )
[ 2dup decode-char ] 2dip rot ; inline [ 2dup decode-char ] 2dip rot ; inline
: (read-rest) ( buf stream encoding n i -- count ) : (read-rest) ( buf stream encoding n i -- count )
2dup = [ (finish-read) ] [ 2dup = [ 4nip ] [
(read-next) [ (read-next) [
swap [ (store-read) ] [ 1 + ] bi (read-rest) swap [ (store-read) ] [ 1 + ] bi (read-rest)
] [ (finish-read) ] if* ] [ 4nip ] if*
] if ; inline recursive ] if ; inline recursive
M: decoder stream-read-unsafe M: decoder stream-read-unsafe
@ -167,11 +164,11 @@ M: decoder stream-read-until
dup CHAR: \n = [ dup CHAR: \n = [
2drop stream-read-until 2drop stream-read-until
] [ ] [
[ 2drop ] 2dip 2nipd
] if ] if
] [ ] [
first-unsafe CHAR: \n = [ [ rest ] dip ] when first-unsafe CHAR: \n = [ [ rest ] dip ] when
[ 2drop ] 2dip 2nipd
] if-empty ] if-empty
] [ ] [
>decoder< decode-until >decoder< decode-until

4
core/io/encodings/utf16/utf16.factor
View File

@ -101,13 +101,13 @@ M: utf16le encode-char ( char stream encoding -- )
drop char>utf16le ; drop char>utf16le ;
: ascii-char>utf16-byte-array ( off n byte-array string -- ) : ascii-char>utf16-byte-array ( off n byte-array string -- )
[ over ] dip string-nth-fast -rot overd string-nth-fast -rot
[ 2 fixnum*fast rot fixnum+fast ] dip [ 2 fixnum*fast rot fixnum+fast ] dip
set-nth-unsafe ; inline set-nth-unsafe ; inline
: ascii-string>utf16-byte-array ( off string -- byte-array ) : ascii-string>utf16-byte-array ( off string -- byte-array )
[ length >fixnum [ <iota> ] [ 2 fixnum*fast <byte-array> ] bi ] keep [ length >fixnum [ <iota> ] [ 2 fixnum*fast <byte-array> ] bi ] keep
[ [ ascii-char>utf16-byte-array ] 2curry with each ] 2keep drop ; inline [ [ ascii-char>utf16-byte-array ] 2curry with each ] keepd ; inline
: ascii-string>utf16le ( string stream -- ) : ascii-string>utf16le ( string stream -- )
[ 0 swap ascii-string>utf16-byte-array ] dip stream-write ; inline [ 0 swap ascii-string>utf16-byte-array ] dip stream-write ; inline

12
core/io/io.factor
View File

@ -118,11 +118,11 @@ SYMBOL: error-stream
stream-exemplar new-sequence ; inline stream-exemplar new-sequence ; inline
: resize-if-necessary ( wanted-n got-n seq -- seq' ) : resize-if-necessary ( wanted-n got-n seq -- seq' )
2over = [ [ 2drop ] dip ] [ resize nip ] if ; inline 2over = [ 2nip ] [ resize nip ] if ; inline
: (read-into-new) ( n stream quot -- seq/f ) : (read-into-new) ( n stream quot -- seq/f )
[ dup ] 2dip [ dup ] 2dip
[ 2dup (new-sequence-for-stream) swap ] dip curry keep [ 2dup (new-sequence-for-stream) swap ] dip keepd
over 0 = [ 3drop f ] [ resize-if-necessary ] if ; inline over 0 = [ 3drop f ] [ resize-if-necessary ] if ; inline
: (read-into) ( buf stream quot -- buf-slice/f ) : (read-into) ( buf stream quot -- buf-slice/f )
@ -173,7 +173,7 @@ CONSTANT: each-block-size 65536
: (each-stream-block-slice) ( ... stream quot: ( ... block-slice -- ... ) block-size -- ... ) : (each-stream-block-slice) ( ... stream quot: ( ... block-slice -- ... ) block-size -- ... )
[ [ drop ] prepose swap ] dip [ [ drop ] prepose swap ] dip
[ swap (new-sequence-for-stream) ] curry keep [ swap (new-sequence-for-stream) ] keepd
[ stream-read-partial-into ] 2curry each-morsel drop ; inline [ stream-read-partial-into ] 2curry each-morsel drop ; inline
: each-stream-block-slice ( ... stream quot: ( ... block-slice -- ... ) -- ... ) : each-stream-block-slice ( ... stream quot: ( ... block-slice -- ... ) -- ... )
@ -194,7 +194,7 @@ CONSTANT: each-block-size 65536
: (stream-contents-by-length) ( stream len -- seq ) : (stream-contents-by-length) ( stream len -- seq )
dup rot dup rot
[ (new-sequence-for-stream) ] [ (new-sequence-for-stream) ]
[ [ stream-read-unsafe ] curry keep resize ] bi ; inline [ [ stream-read-unsafe ] keepd resize ] bi ; inline
: (stream-contents-by-block) ( stream -- seq ) : (stream-contents-by-block) ( stream -- seq )
[ [ ] collector [ each-stream-block ] dip { } like ] [ [ ] collector [ each-stream-block ] dip { } like ]
@ -225,11 +225,11 @@ CONSTANT: each-block-size 65536
<PRIVATE <PRIVATE
: read-loop ( buf stream n i -- count ) : read-loop ( buf stream n i -- count )
2dup = [ nip nip nip ] [ 2dup = [ 3nip ] [
pick stream-read1 [ pick stream-read1 [
over [ pick set-nth-unsafe ] 2curry 3dip over [ pick set-nth-unsafe ] 2curry 3dip
1 + read-loop 1 + read-loop
] [ nip nip nip ] if* ] [ 3nip ] if*
] if ; inline recursive ] if ; inline recursive
: finalize-read-until ( seq sep/f -- seq/f sep/f ) : finalize-read-until ( seq sep/f -- seq/f sep/f )

2
core/io/streams/byte-array/byte-array.factor
View File

@ -13,7 +13,7 @@ M: byte-vector stream-tell length ; inline
512 <byte-vector> swap <encoder> ; inline 512 <byte-vector> swap <encoder> ; inline
: with-byte-writer ( encoding quot -- byte-array ) : with-byte-writer ( encoding quot -- byte-array )
[ <byte-writer> ] dip [ with-output-stream* ] 2keep drop [ <byte-writer> ] dip [ with-output-stream* ] keepd
dup encoder? [ stream>> ] when >byte-array ; inline dup encoder? [ stream>> ] when >byte-array ; inline
TUPLE: byte-reader { underlying byte-array read-only } { i array-capacity } ; TUPLE: byte-reader { underlying byte-array read-only } { i array-capacity } ;

4
core/io/streams/c/c.factor
View File

@ -53,9 +53,9 @@ M: c-reader stream-read1
: read-until-loop ( handle seps accum -- accum ch ) : read-until-loop ( handle seps accum -- accum ch )
pick fgetc dup [ pick fgetc dup [
pick dupd member-eq? pick dupd member-eq?
[ [ 2drop ] 2dip ] [ suffix! read-until-loop ] if [ 2nipd ] [ suffix! read-until-loop ] if
] [ ] [
[ 2drop ] 2dip 2nipd
] if ; inline recursive ] if ; inline recursive
M: c-reader stream-read-until M: c-reader stream-read-until

2
core/io/streams/sequence/sequence.factor
View File

@ -41,7 +41,7 @@ ERROR: not-a-string obj ;
[ integer>fixnum ] [ integer>fixnum ]
[ dup slice? [ [ seq>> ] [ from>> ] bi ] [ 0 ] if ] [ dup slice? [ [ seq>> ] [ from>> ] bi ] [ 0 ] if ]
[ [
swap over stream-element-type +byte+ eq? tuck stream-element-type +byte+ eq?
[ check-byte-array sequence-copy-unsafe ] [ check-byte-array sequence-copy-unsafe ]
[ check-string sequence-copy-unsafe ] if [ check-string sequence-copy-unsafe ] if
] tri* ; inline ] tri* ; inline

3
core/kernel/kernel-docs.factor
View File

@ -40,6 +40,9 @@ HELP: 2over $shuffle ;
HELP: pick $shuffle ; HELP: pick $shuffle ;
HELP: swap $shuffle ; HELP: swap $shuffle ;
HELP: roll $complex-shuffle ;
HELP: -roll $complex-shuffle ;
HELP: tuck $complex-shuffle ;
HELP: rot $complex-shuffle ; HELP: rot $complex-shuffle ;
HELP: -rot $complex-shuffle ; HELP: -rot $complex-shuffle ;
HELP: dupd $complex-shuffle ; HELP: dupd $complex-shuffle ;

5
core/kernel/kernel-tests.factor
View File

@ -132,7 +132,7 @@ IN: kernel.tests
! Regression ! Regression
: (loop) ( a b c d -- ) : (loop) ( a b c d -- )
[ pick ] dip swap [ pick ] dip swap pickd swap pickd swap
< [ [ 1 + ] 3dip (loop) ] [ 4drop ] if ; inline recursive < [ [ 1 + ] 3dip (loop) ] [ 4drop ] if ; inline recursive
: loop ( obj -- ) : loop ( obj -- )
@ -201,3 +201,6 @@ IN: kernel.tests
{ 1 2 3 1 2 3 } [ 1 2 3 3dup ] unit-test { 1 2 3 1 2 3 } [ 1 2 3 3dup ] unit-test
{ 1 2 3 4 1 2 3 4 } [ 1 2 3 4 4dup ] unit-test { 1 2 3 4 1 2 3 4 } [ 1 2 3 4 4dup ] unit-test
{ 2 3 4 1 } [ 1 2 3 4 roll ] unit-test
{ 1 2 3 4 } [ 2 3 4 1 -roll ] unit-test

42
core/kernel/kernel.factor
View File

@ -116,6 +116,39 @@ DEFER: if
: 4dip ( w x y z quot -- w x y z ) swap [ 3dip ] dip ; inline : 4dip ( w x y z quot -- w x y z ) swap [ 3dip ] dip ; inline
! Misfits
: tuck ( x y -- y x y ) dup -rot ; inline
: spin ( x y z -- z y x ) -rot swap ; inline
: rotd ( w x y z -- x y w z ) [ rot ] dip ; inline
: -rotd ( w x y z -- w z x y ) [ -rot ] dip ; inline
: roll ( w x y z -- x y z w ) rotd swap ; inline
: -roll ( w x y z -- z w x y ) swap -rotd ; inline
: nipd ( x y z -- y z ) [ nip ] dip ; inline
: overd ( x y z -- x y x z ) [ over ] dip ; inline
: pickd ( w x y z -- w x y w z ) [ pick ] dip ; inline
: 2nipd ( w x y z -- y z ) [ 2drop ] 2dip ; inline
: 3nipd ( v w x y z -- y z ) [ 3drop ] 2dip ; inline
: 3nip ( w x y z -- z ) 2nip nip ; inline
: 4nip ( v w x y z -- z ) 2nip 2nip ; inline
: 5nip ( u v w x y z -- z ) 3nip 2nip ; inline
: 5drop ( v w x y z -- ) 4drop drop ; inline
: reach ( w x y z -- w x y z w ) [ pick ] dip swap ; inline
! Keepers ! Keepers
: keep ( ..a x quot: ( ..a x -- ..b ) -- ..b x ) : keep ( ..a x quot: ( ..a x -- ..b ) -- ..b x )
over [ call ] dip ; inline over [ call ] dip ; inline
@ -129,6 +162,15 @@ DEFER: if
: 4keep ( ..a w x y z quot: ( ..a w x y z -- ..b ) -- ..b w x y z ) : 4keep ( ..a w x y z quot: ( ..a w x y z -- ..b ) -- ..b w x y z )
[ 4dup ] dip 4dip ; inline [ 4dup ] dip 4dip ; inline
: keepd ( ..a x y quot: ( ..a x y -- ..b x ) -- ..b x )
2keep drop ; inline
: keepdd ( ..a x y z quot: ( ..a x y z -- ..b x ) -- ..b x )
3keep 2drop ; inline
: 2keepd ( ..a x y z quot: ( ..a x y z -- ..b x y ) -- ..b x y )
3keep drop ; inline
! Cleavers ! Cleavers
: bi ( x p q -- ) : bi ( x p q -- )
[ keep ] dip call ; inline [ keep ] dip call ; inline

53
core/math/math.factor
View File

@ -245,50 +245,43 @@ GENERIC: prev-float ( m -- n )
: align ( m w -- n ) : align ( m w -- n )
1 - [ + ] keep bitnot bitand ; inline 1 - [ + ] keep bitnot bitand ; inline
<PRIVATE
: iterate-prep ( n quot -- i n quot ) [ 0 ] 2dip ; inline
: if-iterate? ( i n true false -- ) [ 2over < ] 2dip if ; inline
: iterate-step ( i n quot -- i n quot )
! Apply quot to i, keep i and quot, hide n.
[ nip call ] 3keep ; inline
: iterate-rot ( ? i n quot -- i n quot ? )
[ rot ] dip swap ; inline
: iterate-next ( i n quot -- i' n quot ) [ 1 + ] 2dip ; inline
PRIVATE>
: (each-integer) ( ... i n quot: ( ... i -- ... ) -- ... ) : (each-integer) ( ... i n quot: ( ... i -- ... ) -- ... )
[ iterate-step iterate-next (each-integer) ] 2over < [
[ 3drop ] if-iterate? ; inline recursive [ nip call ] 3keep
[ 1 + ] 2dip (each-integer)
] [
3drop
] if ; inline recursive
: (find-integer) ( ... i n quot: ( ... i -- ... ? ) -- ... i/f ) : (find-integer) ( ... i n quot: ( ... i -- ... ? ) -- ... i/f )
[ 2over < [
iterate-step iterate-rot [ nip call ] 3keep roll
[ 2drop ] [ iterate-next (find-integer) ] if [ 2drop ]
] [ 3drop f ] if-iterate? ; inline recursive [ [ 1 + ] 2dip (find-integer) ] if
] [
3drop f
] if ; inline recursive
: (all-integers?) ( ... i n quot: ( ... i -- ... ? ) -- ... ? ) : (all-integers?) ( ... i n quot: ( ... i -- ... ? ) -- ... ? )
[ 2over < [
iterate-step iterate-rot [ nip call ] 3keep roll
[ iterate-next (all-integers?) ] [ 3drop f ] if [ [ 1 + ] 2dip (all-integers?) ]
] [ 3drop t ] if-iterate? ; inline recursive [ 3drop f ] if
] [
3drop t
] if ; inline recursive
: each-integer ( ... n quot: ( ... i -- ... ) -- ... ) : each-integer ( ... n quot: ( ... i -- ... ) -- ... )
iterate-prep (each-integer) ; inline [ 0 ] 2dip (each-integer) ; inline
: times ( ... n quot: ( ... -- ... ) -- ... ) : times ( ... n quot: ( ... -- ... ) -- ... )
[ drop ] prepose each-integer ; inline [ drop ] prepose each-integer ; inline
: find-integer ( ... n quot: ( ... i -- ... ? ) -- ... i/f ) : find-integer ( ... n quot: ( ... i -- ... ? ) -- ... i/f )
iterate-prep (find-integer) ; inline [ 0 ] 2dip (find-integer) ; inline
: all-integers? ( ... n quot: ( ... i -- ... ? ) -- ... ? ) : all-integers? ( ... n quot: ( ... i -- ... ? ) -- ... ? )
iterate-prep (all-integers?) ; inline [ 0 ] 2dip (all-integers?) ; inline
: find-last-integer ( ... n quot: ( ... i -- ... ? ) -- ... i/f ) : find-last-integer ( ... n quot: ( ... i -- ... ? ) -- ... i/f )
over 0 < [ over 0 < [

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

@ -309,7 +309,7 @@ DEFER: @neg-digit
{ [ dup "bB" member-eq? ] [ 2drop 2 ->radix require-next-digit ] } { [ dup "bB" member-eq? ] [ 2drop 2 ->radix require-next-digit ] }
{ [ dup "oO" member-eq? ] [ 2drop 8 ->radix require-next-digit ] } { [ dup "oO" member-eq? ] [ 2drop 8 ->radix require-next-digit ] }
{ [ dup "xX" member-eq? ] [ 2drop 16 ->radix require-next-digit ] } { [ dup "xX" member-eq? ] [ 2drop 16 ->radix require-next-digit ] }
[ [ drop ] 2dip swap call ] [ nipd swap call ]
} cond } cond
] 2curry next-digit ; inline ] 2curry next-digit ; inline

18
core/sequences/sequences.factor
View File

@ -90,7 +90,7 @@ M: sequence nth-unsafe nth ; inline
M: sequence set-nth-unsafe set-nth ; inline M: sequence set-nth-unsafe set-nth ; inline
: change-nth-unsafe ( i seq quot -- ) : change-nth-unsafe ( i seq quot -- )
[ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline [ [ nth-unsafe ] dip call ] 2keepd set-nth-unsafe ; inline
PRIVATE> PRIVATE>
@ -380,7 +380,7 @@ PRIVATE>
: glue ( seq1 seq2 seq3 -- newseq ) swap 3append ; inline : glue ( seq1 seq2 seq3 -- newseq ) swap 3append ; inline
: change-nth ( ..a i seq quot: ( ..a elt -- ..b newelt ) -- ..b ) : change-nth ( ..a i seq quot: ( ..a elt -- ..b newelt ) -- ..b )
[ [ nth ] dip call ] 3keep drop set-nth-unsafe ; inline [ [ nth ] dip call ] 2keepd set-nth-unsafe ; inline
: min-length ( seq1 seq2 -- n ) [ length ] bi@ min ; inline : min-length ( seq1 seq2 -- n ) [ length ] bi@ min ; inline
@ -447,7 +447,7 @@ PRIVATE>
if ; inline if ; inline
: (accumulate) ( seq identity quot -- identity seq quot ) : (accumulate) ( seq identity quot -- identity seq quot )
swapd [ curry keep ] curry ; inline swapd [ keepd ] curry ; inline
: (accumulate*) ( seq identity quot -- identity seq quot ) : (accumulate*) ( seq identity quot -- identity seq quot )
swapd [ dup ] compose ; inline swapd [ dup ] compose ; inline
@ -464,7 +464,7 @@ PRIVATE>
swapd each ; inline swapd each ; inline
: map-integers ( ... len quot: ( ... i -- ... elt ) exemplar -- ... newseq ) : map-integers ( ... len quot: ( ... i -- ... elt ) exemplar -- ... newseq )
[ over ] dip [ [ collect ] keep ] new-like ; inline overd [ [ collect ] keep ] new-like ; inline
: map-as ( ... seq quot: ( ... elt -- ... newelt ) exemplar -- ... newseq ) : map-as ( ... seq quot: ( ... elt -- ... newelt ) exemplar -- ... newseq )
[ (each) ] dip map-integers ; inline [ (each) ] dip map-integers ; inline
@ -506,7 +506,7 @@ PRIVATE>
[ (2each) ] dip -rot (each-integer) ; inline [ (2each) ] dip -rot (each-integer) ; inline
: 2reduce ( ... seq1 seq2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result ) : 2reduce ( ... seq1 seq2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result )
[ -rot ] dip 2each ; inline -rotd 2each ; inline
: 2map-as ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) exemplar -- ... newseq ) : 2map-as ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) exemplar -- ... newseq )
[ (2each) ] dip map-integers ; inline [ (2each) ] dip map-integers ; inline
@ -524,7 +524,7 @@ PRIVATE>
[ (3each) ] dip map-integers ; inline [ (3each) ] dip map-integers ; inline
: 3map ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... newelt ) -- ... newseq ) : 3map ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... newelt ) -- ... newseq )
[ pick ] dip swap 3map-as ; inline pickd swap 3map-as ; inline
: find-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt ) : find-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ (find-integer) ] (find-from) ; inline [ (find-integer) ] (find-from) ; inline
@ -793,7 +793,7 @@ PRIVATE>
2over = [ 2over = [
4drop 4drop
] [ ] [
[ [ pick [ dup dup ] dip + swap ] dip move-unsafe 1 - ] keep [ [ [ ] [ nip + ] [ 2nip ] 3tri ] dip move-unsafe 1 - ] keep
move-forward move-forward
] if ; ] if ;
@ -808,7 +808,7 @@ PRIVATE>
pick 0 = [ pick 0 = [
3drop 3drop
] [ ] [
pick over length + over [ ] [ nip length + ] [ 2nip ] 3tri
[ pick 0 > [ [ length ] keep ] dip (open-slice) ] 2dip [ pick 0 > [ [ length ] keep ] dip (open-slice) ] 2dip
set-length set-length
] if ; ] if ;
@ -1089,7 +1089,7 @@ M: repetition sum [ elt>> ] [ length>> ] bi * ; inline
[ keep swap ] curry [ [ first ] dip call ] 2keep [ keep swap ] curry [ [ first ] dip call ] 2keep
[ curry 2dip pick over ] curry [ curry 2dip pick over ] curry
] [ ] [
[ [ 2drop ] [ [ 2drop ] 2dip ] if ] compose [ [ 2drop ] [ 2nipd ] if ] compose
] bi* compose 1 each-from drop ; inline ] bi* compose 1 each-from drop ; inline
PRIVATE> PRIVATE>

2
core/slots/slots.factor
View File

@ -212,7 +212,7 @@ M: anonymous-intersection initial-value*
{ [ pinned-alien bootstrap-word over class<= ] [ <bad-alien> t ] } { [ pinned-alien bootstrap-word over class<= ] [ <bad-alien> t ] }
{ [ quotation bootstrap-word over class<= ] [ [ ] t ] } { [ quotation bootstrap-word over class<= ] [ [ ] t ] }
[ dup initial-value* ] [ dup initial-value* ]
} cond [ drop ] 2dip ; } cond nipd ;
GENERIC: make-slot ( desc -- slot-spec ) GENERIC: make-slot ( desc -- slot-spec )

3
core/strings/strings.factor
View File

@ -56,7 +56,8 @@ PRIVATE>
M: string equal? M: string equal?
over string? [ over string? [
2dup [ hashcode ] bi@ eq? ! faster during bootstrap than ``[ hashcode ] bi@``
over hashcode over hashcode eq?
[ sequence= ] [ 2drop f ] if [ sequence= ] [ 2drop f ] if
] [ ] [
2drop f 2drop f

15
core/words/words.factor
View File

@ -111,16 +111,17 @@ M: word parent-word drop f ;
[ changed-effects get add-to-unit ] [ changed-effects get add-to-unit ]
[ dup primitive? [ drop ] [ changed-definition ] if ] bi ; [ dup primitive? [ drop ] [ changed-definition ] if ] bi ;
: set-stack-effect ( effect word -- ) : set-stack-effect ( word effect -- )
2dup "declared-effect" word-prop = [ 2drop ] [ 2dup [ "declared-effect" word-prop ] dip =
[ nip changed-effect ] [ 2drop ] [
[ nip subwords [ changed-effect ] each ] [ drop changed-effect ]
[ swap "declared-effect" set-word-prop ] [ drop subwords [ changed-effect ] each ]
[ "declared-effect" set-word-prop ]
2tri 2tri
] if ; ] if ;
: define-declared ( word def effect -- ) : define-declared ( word def effect -- )
[ nip swap set-stack-effect ] [ drop define ] 3bi ; [ nip set-stack-effect ] [ drop define ] 3bi ;
: make-deprecated ( word -- ) : make-deprecated ( word -- )
t "deprecated" set-word-prop ; t "deprecated" set-word-prop ;
@ -200,7 +201,7 @@ M: word reset-word
] tri ; ] tri ;
: <word> ( name vocab -- word ) : <word> ( name vocab -- word )
2dup [ hashcode ] bi@ hash-combine >fixnum (word) dup new-word ; over hashcode over hashcode hash-combine >fixnum (word) dup new-word ;
: <uninterned-word> ( name -- word ) : <uninterned-word> ( name -- word )
f \ <uninterned-word> counter >fixnum (word) f \ <uninterned-word> counter >fixnum (word)

2
extra/alien/fortran/fortran.factor
View File

@ -414,7 +414,7 @@ PRIVATE>
: ((fortran-invoke)) ( return library function parameters -- quot ) : ((fortran-invoke)) ( return library function parameters -- quot )
{ {
[ 2nip [<fortran-result>] ] [ 2nip [<fortran-result>] ]
[ nip nip nip [fortran-args>c-args] ] [ 3nip [fortran-args>c-args] ]
[ [fortran-invoke] ] [ [fortran-invoke] ]
[ 2nip [fortran-results>] ] [ 2nip [fortran-results>] ]
} 4 ncleave 4 nappend ; } 4 ncleave 4 nappend ;

6
extra/assocs/extras/extras.factor
View File

@ -53,7 +53,7 @@ ERROR: key-exists value key assoc ;
] if ; ] if ;
: kv-with ( obj assoc quot -- assoc curried ) : kv-with ( obj assoc quot -- assoc curried )
swapd [ [ -rot ] dip call ] 2curry ; inline swapd [ -rotd call ] 2curry ; inline
<PRIVATE <PRIVATE
@ -66,13 +66,13 @@ ERROR: key-exists value key assoc ;
PRIVATE> PRIVATE>
: sequence>assoc! ( assoc seq map-quot: ( x -- ..y ) insert-quot: ( ..y assoc -- ) -- assoc ) : sequence>assoc! ( assoc seq map-quot: ( x -- ..y ) insert-quot: ( ..y assoc -- ) -- assoc )
4 nrot (sequence>assoc) ; inline roll (sequence>assoc) ; inline
: assoc>object ( assoc map-quot insert-quot exemplar -- object ) : assoc>object ( assoc map-quot insert-quot exemplar -- object )
clone [ swap curry compose assoc-each ] keep ; inline clone [ swap curry compose assoc-each ] keep ; inline
: assoc>object! ( assoc seq map-quot: ( x -- ..y ) insert-quot: ( ..y assoc -- ) -- object ) : assoc>object! ( assoc seq map-quot: ( x -- ..y ) insert-quot: ( ..y assoc -- ) -- object )
4 nrot assoc>object ; inline roll assoc>object ; inline
: sequence>assoc ( seq map-quot insert-quot exemplar -- assoc ) : sequence>assoc ( seq map-quot insert-quot exemplar -- assoc )
clone (sequence>assoc) ; inline clone (sequence>assoc) ; inline

2
extra/bloom-filters/bloom-filters.factor
View File

@ -127,7 +127,7 @@ PRIVATE>
: relevant-indices ( object bloom-filter -- n quot: ( elt -- n ) ) : relevant-indices ( object bloom-filter -- n quot: ( elt -- n ) )
[ double-hashcodes ] [ #hashes-and-length ] bi* [ double-hashcodes ] [ #hashes-and-length ] bi*
[ -rot ] dip '[ _ _ combine-hashcodes _ mod ] ; inline -rotd '[ _ _ combine-hashcodes _ mod ] ; inline
PRIVATE> PRIVATE>

2
extra/checksums/sodium/sodium.factor
View File

@ -39,7 +39,7 @@ M: sodium-state get-checksum
dup output>> [ dup output>> [
dup state>> [ dup state>> [
over output-size>> [ <byte-array> ] keep over output-size>> [ <byte-array> ] keep
[ crypto_generichash_final check0 ] 2keep drop [ crypto_generichash_final check0 ] keepd
] [ B{ } clone ] if* ] [ B{ } clone ] if*
[ >>output ] keep [ >>output ] keep
] unless* nip ; ] unless* nip ;

7
extra/combinators/extras/extras.factor
View File

@ -40,9 +40,6 @@ MACRO: cleave-array ( quots -- quot )
: 4tri ( w x y z p q r -- ) : 4tri ( w x y z p q r -- )
[ [ 4keep ] dip 4keep ] dip call ; inline [ [ 4keep ] dip 4keep ] dip call ; inline
: keepd ( ..a x y quot: ( ..a x y -- ..b ) -- ..b x )
2keep drop ; inline
: plox ( ... x/f quot: ( ... x -- ... ) -- ... ) : plox ( ... x/f quot: ( ... x -- ... ) -- ... )
dupd when ; inline dupd when ; inline
@ -85,10 +82,10 @@ MACRO:: n-falsify ( n -- quot )
! try the quot, keep the original arg if quot is true ! try the quot, keep the original arg if quot is true
: ?1arg ( obj quot: ( obj -- ? ) -- obj/f ) : ?1arg ( obj quot: ( obj -- ? ) -- obj/f )
[ ?1res ] 2keep drop '[ _ ] [ f ] if ; inline [ ?1res ] keepd '[ _ ] [ f ] if ; inline
: ?2arg ( obj1 obj2 quot: ( obj1 obj2 -- ? ) -- obj1/f obj2/f ) : ?2arg ( obj1 obj2 quot: ( obj1 obj2 -- ? ) -- obj1/f obj2/f )
[ ?2res ] 3keep drop '[ _ _ ] [ f f ] if ; inline [ ?2res ] 2keepd '[ _ _ ] [ f f ] if ; inline
<< <<
: alist>quot* ( default assoc -- quot ) : alist>quot* ( default assoc -- quot )

4
extra/compiler/cfg/gvn/simd/simd.factor
View File

@ -92,8 +92,8 @@ M: ##gather-int-vector-2 rewrite rewrite-gather-vector-2 ;
: rewrite-gather-vector-4 ( insn -- insn/f ) : rewrite-gather-vector-4 ( insn -- insn/f )
dup { [ src1>> ] [ src2>> ] [ src3>> ] [ src4>> ] } cleave [ vreg>insn ] 4 napply dup { [ src1>> ] [ src2>> ] [ src3>> ] [ src4>> ] } cleave [ vreg>insn ] 4 napply
{ {
{ [ 4 ndup [ literal-insn? ] 4 napply and and and ] [ fold-gather-vector-4 ] } { [ 4dup [ literal-insn? ] 4 napply and and and ] [ fold-gather-vector-4 ] }
[ 5 ndrop f ] [ 5drop f ]
} cond ; } cond ;
M: ##gather-vector-4 rewrite rewrite-gather-vector-4 ; M: ##gather-vector-4 rewrite rewrite-gather-vector-4 ;

2
extra/cpu/8080/test/test.factor
View File

@ -55,7 +55,7 @@ IN: cpu.8080.test
224 [ 224 [
32 [ 32 [
over 32 * over + 0x2400 + ! cpu h w addr over 32 * over + 0x2400 + ! cpu h w addr
[ pick ] dip swap ram>> nth [ reach ram>> nth [
[ [
" 0 0 0" write " 0 0 0" write
] [ ] [

Some files were not shown because too many files have changed in this diff Show More