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

86
basis/xml/tests/xmltest/canonxml.html
View File

@ -1,44 +1,44 @@
<HTML> <HTML>
<TITLE>Canonical XML</TITLE> <TITLE>Canonical XML</TITLE>
<BODY> <BODY>
<H1>Canonical XML</H1> <H1>Canonical XML</H1>
<P> <P>
This document defines a subset of XML called canonical XML. This document defines a subset of XML called canonical XML.
The intended use of canonical XML is in testing XML processors, The intended use of canonical XML is in testing XML processors,
as a representation of the result of parsing an XML document. as a representation of the result of parsing an XML document.
<P> <P>
Every well-formed XML document has a unique structurally equivalent Every well-formed XML document has a unique structurally equivalent
canonical XML document. Two structurally equivalent XML canonical XML document. Two structurally equivalent XML
documents have a byte-for-byte identical canonical XML document. documents have a byte-for-byte identical canonical XML document.
Canonicalizing an XML document requires only information that an XML Canonicalizing an XML document requires only information that an XML
processor is required to make available to an application. processor is required to make available to an application.
<P> <P>
A canonical XML document conforms to the following grammar: A canonical XML document conforms to the following grammar:
<PRE> <PRE>
CanonXML ::= Pi* element Pi* CanonXML ::= Pi* element Pi*
element ::= Stag (Datachar | Pi | element)* Etag element ::= Stag (Datachar | Pi | element)* Etag
Stag ::= '&lt;' Name Atts '&gt;' Stag ::= '&lt;' Name Atts '&gt;'
Etag ::= '&lt;/' Name '&gt;' Etag ::= '&lt;/' Name '&gt;'
Pi ::= '&lt;?' Name ' ' (((Char - S) Char*)? - (Char* '?&gt;' Char*)) '?&gt;' Pi ::= '&lt;?' Name ' ' (((Char - S) Char*)? - (Char* '?&gt;' Char*)) '?&gt;'
Atts ::= (' ' Name '=' '"' Datachar* '"')* Atts ::= (' ' Name '=' '"' Datachar* '"')*
Datachar ::= '&amp;amp;' | '&amp;lt;' | '&amp;gt;' | '&amp;quot;' Datachar ::= '&amp;amp;' | '&amp;lt;' | '&amp;gt;' | '&amp;quot;'
| '&amp;#9;'| '&amp;#10;'| '&amp;#13;' | '&amp;#9;'| '&amp;#10;'| '&amp;#13;'
| (Char - ('&amp;' | '&lt;' | '&gt;' | '"' | #x9 | #xA | #xD)) | (Char - ('&amp;' | '&lt;' | '&gt;' | '"' | #x9 | #xA | #xD))
Name ::= (see XML spec) Name ::= (see XML spec)
Char ::= (see XML spec) Char ::= (see XML spec)
S ::= (see XML spec) S ::= (see XML spec)
</PRE> </PRE>
<P> <P>
Attributes are in lexicographical order (in Unicode bit order). Attributes are in lexicographical order (in Unicode bit order).
<P> <P>
A canonical XML document is encoded in UTF-8. A canonical XML document is encoded in UTF-8.
<P> <P>
Ignorable white space is considered significant and is treated equivalently Ignorable white space is considered significant and is treated equivalently
to data. to data.
<P> <P>
<ADDRESS> <ADDRESS>
<A HREF="mailto:jjc@jclark.com">James Clark</A> <A HREF="mailto:jjc@jclark.com">James Clark</A>
</ADDRESS> </ADDRESS>
</BODY> </BODY>
</HTML> </HTML>

120
basis/xml/tests/xmltest/readme.html
View File

@ -1,60 +1,60 @@
<HTML> <HTML>
<TITLE>XML Test Cases</TITLE> <TITLE>XML Test Cases</TITLE>
<BODY> <BODY>
<H1>XML Test Cases version 1998-11-18</H1> <H1>XML Test Cases version 1998-11-18</H1>
<P> <P>
Copyright (C) 1998 James Clark. All rights reserved. Permission is Copyright (C) 1998 James Clark. All rights reserved. Permission is
granted to copy and modify this collection in any way for internal use granted to copy and modify this collection in any way for internal use
within a company or organization. Permission is granted to within a company or organization. Permission is granted to
redistribute the file <code>xmltest.zip</code> containing this redistribute the file <code>xmltest.zip</code> containing this
collection to third parties provided that no modifications of any kind collection to third parties provided that no modifications of any kind
are made to this file. Note that permission to distribute the are made to this file. Note that permission to distribute the
collection in any other form is not granted. collection in any other form is not granted.
<P> <P>
The collection is structured into three directories: The collection is structured into three directories:
<DL> <DL>
<DT><CODE>not-wf</CODE> <DT><CODE>not-wf</CODE>
<DD>this contains cases that are not well-formed XML documents <DD>this contains cases that are not well-formed XML documents
<DT><CODE>valid</CODE> <DT><CODE>valid</CODE>
<DD>this contains cases that are valid XML documents <DD>this contains cases that are valid XML documents
<DT><CODE>invalid</CODE> <DT><CODE>invalid</CODE>
<DD>this contains cases that are well-formed XML documents <DD>this contains cases that are well-formed XML documents
but are not valid XML documents but are not valid XML documents
</DL> </DL>
<P> <P>
The <CODE>not-wf</CODE> and <CODE>valid</CODE> directories each have The <CODE>not-wf</CODE> and <CODE>valid</CODE> directories each have
three subdirectories: three subdirectories:
<DL> <DL>
<DT> <DT>
<CODE>sa</CODE> <CODE>sa</CODE>
<DD> <DD>
this contains cases that are standalone (as defined in XML) and do not this contains cases that are standalone (as defined in XML) and do not
have references to external general entities have references to external general entities
<DT> <DT>
<CODE>ext-sa</CODE> <CODE>ext-sa</CODE>
<DD> <DD>
this contains case that are standalone and have references to external this contains case that are standalone and have references to external
general entities general entities
<DT> <DT>
<CODE>not-sa</CODE> <CODE>not-sa</CODE>
<DD> <DD>
this contains cases that are not standalone this contains cases that are not standalone
</DL> </DL>
<P> <P>
In each directory, files with a <CODE>.xml</CODE> extension are the In each directory, files with a <CODE>.xml</CODE> extension are the
XML document test cases, and files with a <CODE>.ent</CODE> extension XML document test cases, and files with a <CODE>.ent</CODE> extension
are external entities referenced by the test cases. are external entities referenced by the test cases.
<P> <P>
Within the <CODE>valid</CODE> directory, each of these three Within the <CODE>valid</CODE> directory, each of these three
subdirectories has an <CODE>out</CODE> subdirectory which contains an subdirectories has an <CODE>out</CODE> subdirectory which contains an
equivalent <A HREF="canonxml.html">canonical XML</A> document for each equivalent <A HREF="canonxml.html">canonical XML</A> document for each
of the cases. of the cases.
<P> <P>
<P> <P>
Bug reports and contributions of new test cases are welcome. Bug reports and contributions of new test cases are welcome.
<P> <P>
<ADDRESS> <ADDRESS>
<A HREF="mailto:jjc@jclark.com">James Clark</A> <A HREF="mailto:jjc@jclark.com">James Clark</A>
</ADDRESS> </ADDRESS>
</BODY> </BODY>
</HTML> </HTML>

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 )

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