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
parent
c477757fa0
commit
9f213f96f6
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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> ;
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 -- ? )
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 ]
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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) ;
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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 }
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ]
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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?
|
||||||
|
|
||||||
|
|
|
@ -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>
|
||||||
|
|
||||||
|
|
|
@ -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 -- ? )
|
||||||
|
|
||||||
|
|
|
@ -83,6 +83,7 @@ SYMBOL: vocab-articles
|
||||||
] map ;
|
] map ;
|
||||||
|
|
||||||
: contains-funky-elements? ( element -- ? )
|
: contains-funky-elements? ( element -- ? )
|
||||||
|
B
|
||||||
{
|
{
|
||||||
$shuffle
|
$shuffle
|
||||||
$complex-shuffle
|
$complex-shuffle
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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+ ] }
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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:
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 [
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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' )
|
||||||
|
|
|
@ -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) ;
|
||||||
|
|
|
@ -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@
|
||||||
|
|
|
@ -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)
|
||||||
] ;
|
] ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 [
|
||||||
|
|
|
@ -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,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
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 -- )
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 [
|
||||||
|
|
|
@ -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> ] ;
|
||||||
|
|
||||||
|
|
|
@ -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>> [
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ] [
|
||||||
|
|
|
@ -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>
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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>
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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 } ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 < [
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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>
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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>
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
Loading…
Reference in New Issue