SYMBOL: jit-if-jump
SYMBOL: jit-dispatch-word
SYMBOL: jit-dispatch
+SYMBOL: jit-dip-word
+SYMBOL: jit-dip
+SYMBOL: jit-2dip-word
+SYMBOL: jit-2dip
+SYMBOL: jit-3dip-word
+SYMBOL: jit-3dip
SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
! Default definition for undefined words
SYMBOL: undefined-quot
-: userenv-offset ( symbol -- n )
- {
+: userenvs ( -- assoc )
+ H{
{ bootstrap-boot-quot 20 }
{ bootstrap-global 21 }
{ jit-code-format 22 }
{ jit-push-immediate 36 }
{ jit-declare-word 42 }
{ jit-save-stack 43 }
+ { jit-dip-word 44 }
+ { jit-dip 45 }
+ { jit-2dip-word 46 }
+ { jit-2dip 47 }
+ { jit-3dip-word 48 }
+ { jit-3dip 49 }
{ undefined-quot 60 }
- } at header-size + ;
+ } ; inline
+
+: userenv-offset ( symbol -- n )
+ userenvs at header-size + ;
: emit ( cell -- ) image get push ;
\ dispatch jit-dispatch-word set
\ do-primitive jit-primitive-word set
\ declare jit-declare-word set
+ \ dip jit-dip-word set
+ \ 2dip jit-2dip-word set
+ \ 3dip jit-3dip-word set
[ undefined ] undefined-quot set
{
jit-code-format
jit-if-jump
jit-dispatch-word
jit-dispatch
+ jit-dip-word
+ jit-dip
+ jit-2dip-word
+ jit-2dip
+ jit-3dip-word
+ jit-3dip
jit-epilog
jit-return
jit-profiling
: mod-arg ( -- reg ) EDX ;
: arg0 ( -- reg ) EAX ;
: arg1 ( -- reg ) EDX ;
+: arg2 ( -- reg ) ECX ;
: temp-reg ( -- reg ) EBX ;
: stack-reg ( -- reg ) ESP ;
: ds-reg ( -- reg ) ESI ;
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
: arg0 ( -- reg ) RDI ;
: arg1 ( -- reg ) RSI ;
+: arg2 ( -- reg ) RDX ;
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
call
: stack-frame-size ( -- n ) 8 bootstrap-cells ;
: arg0 ( -- reg ) RCX ;
: arg1 ( -- reg ) RDX ;
+: arg2 ( -- reg ) R8 ;
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
call
arg0 quot-xt-offset [+] JMP ! execute branch
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
+! The jit->r words cannot clobber arg0
+
+: jit->r ( -- )
+ rs-reg bootstrap-cell ADD
+ temp-reg ds-reg [] MOV
+ ds-reg bootstrap-cell SUB
+ rs-reg [] temp-reg MOV ;
+
+: jit-2>r ( -- )
+ rs-reg 2 bootstrap-cells ADD
+ temp-reg ds-reg [] MOV
+ arg1 ds-reg -1 bootstrap-cells [+] MOV
+ ds-reg 2 bootstrap-cells SUB
+ rs-reg [] temp-reg MOV
+ rs-reg -1 bootstrap-cells [+] arg1 MOV ;
+
+: jit-3>r ( -- )
+ rs-reg 3 bootstrap-cells ADD
+ temp-reg ds-reg [] MOV
+ arg1 ds-reg -1 bootstrap-cells [+] MOV
+ arg2 ds-reg -2 bootstrap-cells [+] MOV
+ ds-reg 3 bootstrap-cells SUB
+ rs-reg [] temp-reg MOV
+ rs-reg -1 bootstrap-cells [+] arg1 MOV
+ rs-reg -2 bootstrap-cells [+] arg2 MOV ;
+
+: jit-r> ( -- )
+ ds-reg bootstrap-cell ADD
+ temp-reg rs-reg [] MOV
+ rs-reg bootstrap-cell SUB
+ ds-reg [] temp-reg MOV ;
+
+: jit-2r> ( -- )
+ ds-reg 2 bootstrap-cells ADD
+ temp-reg rs-reg [] MOV
+ arg1 rs-reg -1 bootstrap-cells [+] MOV
+ rs-reg 2 bootstrap-cells SUB
+ ds-reg [] temp-reg MOV
+ ds-reg -1 bootstrap-cells [+] arg1 MOV ;
+
+: jit-3r> ( -- )
+ ds-reg 3 bootstrap-cells ADD
+ temp-reg rs-reg [] MOV
+ arg1 rs-reg -1 bootstrap-cells [+] MOV
+ arg2 rs-reg -2 bootstrap-cells [+] MOV
+ rs-reg 3 bootstrap-cells SUB
+ ds-reg [] temp-reg MOV
+ ds-reg -1 bootstrap-cells [+] arg1 MOV
+ ds-reg -2 bootstrap-cells [+] arg2 MOV ;
+
+[
+ arg0 0 MOV ! load quotation addr
+ arg0 arg0 [] MOV ! load quotation
+ jit->r
+ arg0 quot-xt-offset [+] CALL ! call quotation
+ jit-r>
+] rc-absolute-cell rt-literal 1 rex-length + jit-dip jit-define
+
+[
+ arg0 0 MOV ! load quotation addr
+ arg0 arg0 [] MOV ! load quotation
+ jit-2>r
+ arg0 quot-xt-offset [+] CALL ! call quotation
+ jit-2r>
+] rc-absolute-cell rt-literal 1 rex-length + jit-2dip jit-define
+
+[
+ arg0 0 MOV ! load quotation addr
+ arg0 arg0 [] MOV ! load quotation
+ jit-3>r
+ arg0 quot-xt-offset [+] CALL ! call quotation
+ jit-3r>
+] rc-absolute-cell rt-literal 1 rex-length + jit-3dip jit-define
+
[
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
] f f f jit-epilog jit-define
ds-reg [] arg1 MOV
] f f f \ -rot define-sub-primitive
-[
- rs-reg bootstrap-cell ADD
- arg0 ds-reg [] MOV
- ds-reg bootstrap-cell SUB
- rs-reg [] arg0 MOV
-] f f f \ >r define-sub-primitive
+[ jit->r ] f f f \ >r define-sub-primitive
-[
- ds-reg bootstrap-cell ADD
- arg0 rs-reg [] MOV
- rs-reg bootstrap-cell SUB
- ds-reg [] arg0 MOV
-] f f f \ r> define-sub-primitive
+[ jit-r> ] f f f \ r> define-sub-primitive
! Comparisons
: jit-compare ( insn -- )
M: object infer-call*
\ literal-expected inference-warning ;
+: infer-slip ( -- )
+ 1 infer->r pop-d infer-call 1 infer-r> ;
+
+: infer-2slip ( -- )
+ 2 infer->r pop-d infer-call 2 infer-r> ;
+
+: infer-3slip ( -- )
+ 3 infer->r pop-d infer-call 3 infer-r> ;
+
: infer-curry ( -- )
2 consume-d
dup first2 <curried> make-known
{ \ declare [ infer-declare ] }
{ \ call [ pop-d infer-call ] }
{ \ (call) [ pop-d infer-call ] }
+ { \ slip [ infer-slip ] }
+ { \ 2slip [ infer-2slip ] }
+ { \ 3slip [ infer-3slip ] }
{ \ curry [ infer-curry ] }
{ \ compose [ infer-compose ] }
{ \ execute [ infer-execute ] }
(( value -- )) apply-word/effect ;
{
- >r r> declare call (call) curry compose execute (execute) if
-dispatch <tuple-boa> (throw) load-locals get-local drop-locals
-do-primitive alien-invoke alien-indirect alien-callback
+ >r r> declare call (call) slip 2slip 3slip curry compose
+ execute (execute) if dispatch <tuple-boa> (throw)
+ load-locals get-local drop-locals do-primitive alien-invoke
+ alien-indirect alien-callback
} [ t "special" set-word-prop ] each
{ call execute dispatch load-locals get-local drop-locals }
M: array clone (clone) ;
M: array length length>> ;
-M: array nth-unsafe >r >fixnum r> array-nth ;
-M: array set-nth-unsafe >r >fixnum r> set-array-nth ;
+M: array nth-unsafe [ >fixnum ] dip array-nth ;
+M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ;
M: array resize resize-array ;
: >array ( seq -- array ) { } clone-like ;
3drop f
] [
3dup nth-unsafe at*
- [ >r 3drop r> ] [ drop >r 1- r> (assoc-stack) ] if
+ [ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if
] if ; inline recursive
: assoc-stack ( key seq -- value )
: assoc-hashcode ( n assoc -- code )
[
- >r over r> hashcode* 2/ >r dupd hashcode* r> bitxor
+ [ over ] dip hashcode* 2/ [ dupd hashcode* ] dip bitxor
] { } assoc>map hashcode* ;
: assoc-intersect ( assoc1 assoc2 -- intersection )
[ 0 or + ] change-at ;
: map>assoc ( seq quot exemplar -- assoc )
- >r [ 2array ] compose { } map-as r> assoc-like ; inline
+ [ [ 2array ] compose { } map-as ] dip assoc-like ; inline
: extract-keys ( seq assoc -- subassoc )
[ [ dupd at ] curry ] keep map>assoc ;
M: sequence assoc-size length ;
M: sequence assoc-clone-like
- >r >alist r> clone-like ;
+ [ >alist ] dip clone-like ;
M: sequence assoc-like
- >r >alist r> like ;
+ [ >alist ] dip like ;
M: sequence >alist ;
[ "slots" set-word-prop ] [ define-accessors ] 2bi ;
: define-builtin ( symbol slotspec -- )
- >r [ define-builtin-predicate ] keep
- r> define-builtin-slots ;
+ [ [ define-builtin-predicate ] keep ] dip define-builtin-slots ;
"fixnum" "math" create register-builtin
"bignum" "math" create register-builtin
[ ]
[
[
- \ >r ,
- callable instance-check-quot %
- \ r> ,
+ callable instance-check-quot [ dip ] curry %
callable instance-check-quot %
tuple-layout ,
\ <tuple-boa> ,
! Primitive words
: make-primitive ( word vocab n -- )
- >r create dup reset-word r>
+ [ create dup reset-word ] dip
[ do-primitive ] curry [ ] like define ;
{
{ "unimplemented" "kernel.private" }
{ "gc-reset" "memory" }
}
-[ >r first2 r> make-primitive ] each-index
+[ [ first2 ] dip make-primitive ] each-index
! Bump build number
"build" "kernel" create build 1+ 1quotation define
GENERIC: checksum-lines ( lines checksum -- value )
-M: checksum checksum-bytes >r binary <byte-reader> r> checksum-stream ;
+M: checksum checksum-bytes
+ [ binary <byte-reader> ] dip checksum-stream ;
-M: checksum checksum-stream >r contents r> checksum-bytes ;
+M: checksum checksum-stream
+ [ contents ] dip checksum-bytes ;
-M: checksum checksum-lines >r B{ CHAR: \n } join r> checksum-bytes ;
+M: checksum checksum-lines
+ [ B{ CHAR: \n } join ] dip checksum-bytes ;
: checksum-file ( path checksum -- value )
- >r binary <file-reader> r> checksum-stream ;
+ [ binary <file-reader> ] dip checksum-stream ;
: hex-string ( seq -- str )
[ >hex 2 CHAR: 0 pad-left ] { } map-as concat ;
256 [
8 [
- dup even? >r 2/ r> [ crc32-polynomial bitxor ] unless
+ [ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless
] times >bignum
] map 0 crc32-table copy
INSTANCE: crc32 checksum
-: init-crc32 drop >r HEX: ffffffff dup r> ; inline
+: init-crc32 drop [ HEX: ffffffff dup ] dip ; inline
: finish-crc32 bitxor 4 >be ; inline
\ flatten-class must-infer\r
\ flatten-builtin-class must-infer\r
\r
-: class-and* ( cls1 cls2 cls3 -- ? ) >r class-and r> class= ;\r
+: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;\r
\r
-: class-or* ( cls1 cls2 cls3 -- ? ) >r class-or r> class= ;\r
+: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;\r
\r
[ t ] [ object object object class-and* ] unit-test\r
[ t ] [ fixnum object fixnum class-and* ] unit-test\r
20 [ random-boolean-op ] [ ] replicate-as dup .\r
[ infer in>> [ random-boolean ] replicate dup . ] keep\r
\r
- [ >r [ ] each r> call ] 2keep\r
+ [ [ [ ] each ] dip call ] 2keep\r
\r
- >r [ boolean>class ] each r> [ boolean-op>class-op ] map call object class=\r
+ [ [ boolean>class ] each ] dip [ boolean-op>class-op ] map call object class=\r
\r
=\r
] unit-test\r
C: <anonymous-complement> anonymous-complement\r
\r
: 2cache ( key1 key2 assoc quot -- value )\r
- >r >r 2array r> [ first2 ] r> compose cache ; inline\r
+ [ 2array ] 2dip [ first2 ] prepose cache ; inline\r
\r
GENERIC: valid-class? ( obj -- ? )\r
\r
swap superclass dup [ swap class<= ] [ 2drop f ] if ;\r
\r
: left-anonymous-union<= ( first second -- ? )\r
- >r members>> r> [ class<= ] curry all? ;\r
+ [ members>> ] dip [ class<= ] curry all? ;\r
\r
: right-anonymous-union<= ( first second -- ? )\r
members>> [ class<= ] with contains? ;\r
\r
: left-anonymous-intersection<= ( first second -- ? )\r
- >r participants>> r> [ class<= ] curry contains? ;\r
+ [ participants>> ] dip [ class<= ] curry contains? ;\r
\r
: right-anonymous-intersection<= ( first second -- ? )\r
participants>> [ class<= ] with all? ;\r
} cond ;\r
\r
: left-anonymous-complement<= ( first second -- ? )\r
- >r normalize-complement r> class<= ;\r
+ [ normalize-complement ] dip class<= ;\r
\r
PREDICATE: nontrivial-anonymous-complement < anonymous-complement\r
class>> {\r
: sort-classes ( seq -- newseq )\r
[ [ name>> ] compare ] sort >vector\r
[ dup empty? not ]\r
- [ dup largest-class >r over delete-nth r> ]\r
+ [ dup largest-class [ over delete-nth ] dip ]\r
[ ] produce nip ;\r
\r
: min-class ( class seq -- class/f )\r
[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
: accessor-exists? ( class name -- ? )
- >r "forget-accessors-test" "classes.tuple.tests" lookup r>
+ [ "forget-accessors-test" "classes.tuple.tests" lookup ] dip
">>" append "accessors" lookup method >boolean ;
[ t ] [ "x" accessor-exists? ] unit-test
: tuple>array ( tuple -- array )
prepare-tuple>array
- >r copy-tuple-slots r>
+ [ copy-tuple-slots ] dip
first prefix ;
: tuple-slots ( tuple -- seq )
: update-slot ( old-values n class initial -- value )
pick [
- >r >r swap nth dup r> instance? r> swap
+ [ [ swap nth dup ] dip instance? ] dip swap
[ drop ] [ nip ] if
- ] [ >r 3drop r> ] if ;
+ ] [ [ 3drop ] dip ] if ;
: apply-slot-permutation ( old-values triples -- new-values )
[ first3 update-slot ] with map ;
class-usages [ tuple-class? ] filter ;
: each-subclass ( class quot -- )
- >r subclasses r> each ; inline
+ [ subclasses ] dip each ; inline
: redefine-tuple-class ( class superclass slots -- )
[
M: tuple hashcode*
[
[ class hashcode ] [ tuple-size ] [ ] tri
- >r rot r> [
+ [ rot ] dip [
swapd array-nth hashcode* sequence-hashcode-step
] 2curry each
] recursive-hashcode ;
{ $code
"! Equivalent"
"{ [ p ] [ q ] [ r ] [ s ] } spread"
- ">r >r >r p r> q r> r r> s"
+ "[ [ [ p ] dip q ] dip r ] dip s"
}
} ;
drop [ swap adjoin ] curry each
] [
[
- >r 2dup r> hashcode pick length rem rot nth adjoin
+ [ 2dup ] dip hashcode pick length rem rot nth adjoin
] each 2drop
] if ;
next-power-of-2 swap [ nip clone ] curry map ;
: distribute-buckets ( alist initial quot -- buckets )
- swapd [ >r dup first r> call 2array ] curry map
+ swapd [ [ dup first ] dip call 2array ] curry map
[ length <buckets> dup ] keep
[ first2 (distribute-buckets) ] with each ; inline
: hash-case-table ( default assoc -- array )
V{ } [ 1array ] distribute-buckets
- [ [ >r literalize r> ] assoc-map linear-case-quot ] with map ;
+ [ [ [ literalize ] dip ] assoc-map linear-case-quot ] with map ;
: hash-dispatch-quot ( table -- quot )
[ length 1- [ fixnum-bitand ] curry ] keep
{ [ dup [ length 4 <= ] [ [ word? ] contains? ] bi or ] [ drop linear-case-quot ] }
{ [ dup contiguous-range? ] [ drop dispatch-case-quot ] }
{ [ dup [ wrapper? ] contains? not ] [ drop hash-case-quot ] }
- { [ dup [ wrapper? ] all? ] [ drop [ >r wrapped>> r> ] assoc-map hash-case-quot ] }
+ { [ dup [ wrapper? ] all? ] [ drop [ [ wrapped>> ] dip ] assoc-map hash-case-quot ] }
[ drop linear-case-quot ]
} cond ;
! assert-depth
: trim-datastacks ( seq1 seq2 -- seq1' seq2' )
- 2dup [ length ] bi@ min tuck tail >r tail r> ;
+ 2dup [ length ] bi@ min tuck [ tail ] 2bi@ ;
ERROR: relative-underflow stack ;
ERROR: relative-overflow stack ;
: assert-depth ( quot -- )
- >r datastack r> dip >r datastack r>
+ [ datastack ] dip dip [ datastack ] dip
2dup [ length ] compare {
{ +lt+ [ trim-datastacks nip relative-underflow ] }
{ +eq+ [ 2drop ] }
: errors-of-type ( type -- assoc )
compiler-errors get-global
- swap [ >r nip compiler-error-type r> eq? ] curry
+ swap [ [ nip compiler-error-type ] dip eq? ] curry
assoc-filter ;
: compiler-errors. ( type -- )
#! ( value f r:capture r:restore )
#! Execution begins right after the call to 'continuation'.
#! The 'restore' branch is taken.
- >r >r dummy-1 continuation r> r> [ dummy-2 ] prepose ?if ; inline
+ [ dummy-1 continuation ] 2dip [ dummy-2 ] prepose ?if ; inline
: callcc0 ( quot -- ) [ drop ] ifcc ; inline
set-catchstack
set-namestack
set-retainstack
- >r set-datastack r>
+ [ set-datastack ] dip
set-callstack ;
: (continue-with) ( obj continuation -- )
set-catchstack
set-namestack
set-retainstack
- >r set-datastack drop 4 getenv f 4 setenv f r>
+ [ set-datastack drop 4 getenv f 4 setenv f ] dip
set-callstack ;
PRIVATE>
c> continue-with ;
: recover ( try recovery -- )
- >r [ swap >c call c> drop ] curry r> ifcc ; inline
+ [ [ swap >c call c> drop ] curry ] dip ifcc ; inline
: ignore-errors ( quot -- )
[ drop ] recover ; inline
: cleanup ( try cleanup-always cleanup-error -- )
- over >r compose [ dip rethrow ] curry
- recover r> call ; inline
+ [ compose [ dip rethrow ] curry recover ] [ drop ] 2bi call ; inline
ERROR: attempt-all-error ;
: math-upgrade ( class1 class2 -- quot )
[ math-class-max ] 2keep
- >r over r> (math-upgrade) >r (math-upgrade)
- dup empty? [ [ dip ] curry [ ] like ] unless
- r> append ;
+ [ over ] dip (math-upgrade) [
+ (math-upgrade)
+ dup empty? [ [ dip ] curry [ ] like ] unless
+ ] dip append ;
ERROR: no-math-method left right generic ;
: math-method ( word class1 class2 -- quot )
2dup and [
- 2dup math-upgrade >r
- math-class-max over order min-class applicable-method
- r> prepend
+ 2dup math-upgrade
+ [ math-class-max over order min-class applicable-method ] dip
+ prepend
] [
2drop object-method
] if ;
dup
\ over [
dup math-class? [
- \ dup [ >r 2dup r> math-method ] math-vtable
+ \ dup [ [ 2dup ] dip math-method ] math-vtable
] [
over object-method
] if nip
[ over assumed [ engine>quot ] with-variable ] assoc-map ;
: if-small? ( assoc true false -- )
- >r >r dup assoc-size 4 <= r> r> if ; inline
+ [ dup assoc-size 4 <= ] 2dip if ; inline
: linear-dispatch-quot ( alist -- quot )
default get [ drop ] prepend swap
{ 0 [ [ dup ] ] }
{ 1 [ [ over ] ] }
{ 2 [ [ pick ] ] }
- [ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
+ [ 1- (picker) [ dip swap ] curry ]
} case ;
: picker ( -- quot ) \ (dispatch#) get (picker) ;
C: <predicate-dispatch-engine> predicate-dispatch-engine
: class-predicates ( assoc -- assoc )
- [ >r "predicate" word-prop picker prepend r> ] assoc-map ;
+ [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ;
: keep-going? ( assoc -- ? )
assumed get swap second first class<= ;
M: lo-tag-dispatch-engine engine>quot
methods>> engines>quots*
- [ >r lo-tag-number r> ] assoc-map
+ [ [ lo-tag-number ] dip ] assoc-map
[
picker % [ tag ] % [
sort-tags linear-dispatch-quot
M: hi-tag-dispatch-engine engine>quot
methods>> engines>quots*
- [ >r hi-tag-number r> ] assoc-map
+ [ [ hi-tag-number ] dip ] assoc-map
[
picker % hi-tag-quot % [
sort-tags linear-dispatch-quot
] [
num-tags get , \ fixnum-fast ,
- [ >r num-tags get - r> ] assoc-map
+ [ [ num-tags get - ] dip ] assoc-map
num-hi-tags direct-dispatch-quot
] if-small? %
] [ ] make ;
] change-at ;
: flatten-method ( class method assoc -- )
- >r >r dup flatten-class keys swap r> r> [
- >r spin r> push-method
+ [ dup flatten-class keys swap ] 2dip [
+ [ spin ] dip push-method
] 3curry each ;
: flatten-methods ( assoc -- assoc' )
T{ standard-combination f 0 } define-generic ;
: with-standard ( combination quot -- quot' )
- >r #>> (dispatch#) r> with-variable ; inline
+ [ #>> (dispatch#) ] dip with-variable ; inline
M: standard-generic extra-values drop 0 ;
growable-check
2dup length >= [
2dup capacity >= [ over new-size over expand ] when
- >r >fixnum r>
+ [ >fixnum ] dip
over 1 fixnum+fast over (>>length)
] [
- >r >fixnum r>
+ [ >fixnum ] dip
] if ; inline
M: growable set-nth ensure set-nth-unsafe ;
[ H{ { -1 4 } { -3 16 } { -5 36 } } ] [
H{ { 1 2 } { 3 4 } { 5 6 } }
- [ >r neg r> sq ] assoc-map
+ [ [ neg ] dip sq ] assoc-map
] unit-test
! Bug discovered by littledan
length>> 1 fixnum-fast fixnum-bitand ; inline
: hash@ ( key array -- i )
- >r hashcode >fixnum dup fixnum+fast r> wrap ; inline
+ [ hashcode >fixnum dup fixnum+fast ] dip wrap ; inline
: probe ( array i -- array i )
2 fixnum+fast over wrap ; inline
M: hashtable delete-at ( key hash -- )
tuck key@ [
- >r >r ((tombstone)) dup r> r> set-nth-pair
+ [ ((tombstone)) dup ] 2dip set-nth-pair
hash-deleted+
] [
3drop
[ count>> ] [ deleted>> ] bi - ;
: rehash ( hash -- )
- dup >alist >r
+ dup >alist [
dup clear-assoc
- r> (rehash) ;
+ ] dip (rehash) ;
M: hashtable set-at ( value key hash -- )
dup ?grow-hash
: push-unsafe ( elt seq -- )
[ length ] keep
[ underlying>> set-array-nth ]
- [ >r 1+ r> (>>length) ]
+ [ [ 1+ ] dip (>>length) ]
2bi ; inline
PRIVATE>
M: hashtable >alist
[ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [
[
- >r
- >r 1 fixnum-shift-fast r>
- [ array-nth ] [ >r 1 fixnum+fast r> array-nth ] 2bi r>
+ [
+ [ 1 fixnum-shift-fast ] dip
+ [ array-nth ] [ [ 1 fixnum+fast ] dip array-nth ] 2bi
+ ] dip
pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if
] 2curry each
] keep { } like ;
: ((read-until)) ( buf quot: ( -- char stop? ) -- string/f sep/f )
dup call
- [ >r drop "" like r> ]
+ [ [ drop "" like ] dip ]
[ pick push ((read-until)) ] if ; inline recursive
: (read-until) ( quot -- string/f sep/f )
<file-reader> lines ;
: with-file-reader ( path encoding quot -- )
- >r <file-reader> r> with-input-stream ; inline
+ [ <file-reader> ] dip with-input-stream ; inline
: file-contents ( path encoding -- str )
<file-reader> contents ;
: with-file-writer ( path encoding quot -- )
- >r <file-writer> r> with-output-stream ; inline
+ [ <file-writer> ] dip with-output-stream ; inline
: set-file-lines ( seq path encoding -- )
[ [ print ] each ] with-file-writer ;
[ write ] with-file-writer ;
: with-file-appender ( path encoding quot -- )
- >r <file-appender> r> with-output-stream ; inline
+ [ <file-appender> ] dip with-output-stream ; inline
! Pathnames
: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
{ [ dup head.? ] [ rest trim-left-separators append-path ] }
{ [ dup head..? ] [
2 tail trim-left-separators
- >r parent-directory r> append-path
+ [ parent-directory ] dip append-path
] }
{ [ over absolute-path? over first path-separator? and ] [
- >r 2 head r> append
+ [ 2 head ] dip append
] }
[
- >r trim-right-separators "/" r>
+ [ trim-right-separators "/" ] dip
trim-left-separators 3append
]
} cond ;
HOOK: read-link io-backend ( symlink -- path )
: copy-link ( target symlink -- )
- >r read-link r> make-link ;
+ [ read-link ] dip make-link ;
SYMBOL: +regular-file+
SYMBOL: +directory+
(normalize-path) current-directory set ;
: with-directory ( path quot -- )
- >r (normalize-path) current-directory r> with-variable ; inline
+ [ (normalize-path) current-directory ] dip with-variable ; inline
! Creating directories
HOOK: make-directory io-backend ( path -- )
[ ] cleanup ; inline
: tabular-output ( style quot -- )
- swap >r { } make r> output-stream get stream-write-table ; inline
+ swap [ { } make ] dip output-stream get stream-write-table ; inline
: with-row ( quot -- )
{ } make , ; inline
] if ; inline
: with-nesting ( style quot -- )
- >r output-stream get make-block-stream
- r> with-output-stream ; inline
+ [ output-stream get make-block-stream ] dip
+ with-output-stream ; inline
: print ( string -- ) output-stream get stream-print ;
512 <byte-vector> swap <encoder> ;
: with-byte-writer ( encoding quot -- byte-array )
- >r <byte-writer> r> [ output-stream get ] compose with-output-stream*
+ [ <byte-writer> ] dip [ output-stream get ] compose with-output-stream*
dup encoder? [ stream>> ] when >byte-array ; inline
: <byte-reader> ( byte-array encoding -- stream )
- >r >byte-vector dup reverse-here r> <decoder> ;
+ [ >byte-vector dup reverse-here ] dip <decoder> ;
: with-byte-reader ( byte-array encoding quot -- )
- >r <byte-reader> r> with-input-stream* ; inline
+ [ <byte-reader> ] dip with-input-stream* ; inline
[ style>> ] [ stream>> ] bi stream-format ;
M: style-stream stream-write1
- >r 1string r> stream-write ;
+ [ 1string ] dip stream-write ;
M: style-stream make-span-stream
do-nested-style make-span-stream ;
] unless ;
: map-last ( seq quot -- seq )
- >r dup length <reversed> [ zero? ] r> compose 2map ; inline
+ [ dup length <reversed> ] dip [ 0 = ] prepose 2map ; inline
PRIVATE>
>sbuf dup reverse-here null-encoding <decoder> ;
: with-string-reader ( str quot -- )
- >r <string-reader> r> with-input-stream ; inline
+ [ <string-reader> ] dip with-input-stream ; inline
INSTANCE: growable plain-writer
HELP: roll $shuffle ;
HELP: -roll $shuffle ;
-HELP: >r ( x -- )
-{ $values { "x" object } } { $description "Moves the top of the data stack to the retain stack." } ;
-
-HELP: r> ( -- x )
-{ $values { "x" object } } { $description "Moves the top of the retain stack to the data stack." } ;
-
HELP: datastack ( -- ds )
{ $values { "ds" array } }
{ $description "Outputs an array containing a copy of the data stack contents right before the call to this word, with the top of the stack at the end of the array." } ;
HELP: keep
{ $values { "quot" { $quotation "( x -- )" } } { "x" object } }
-{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." } ;
+{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." }
+{ $examples
+ { $example "USING: arrays kernel prettyprint ;" "2 \"greetings\" [ <array> ] keep 2array ." "{ { \"greetings\" \"greetings\" } \"greetings\" }" }
+} ;
HELP: 2keep
{ $values { "quot" { $quotation "( x y -- )" } } { "x" object } { "y" object } }
"The following two lines are equivalent:"
{ $code
"[ p ] [ q ] bi*"
- ">r p r> q"
+ "[ p ] dip q"
}
} ;
"The following two lines are equivalent:"
{ $code
"[ p ] [ q ] 2bi*"
- ">r >r p r> r> q"
+ "[ p ] 2dip q"
}
} ;
"The following two lines are equivalent:"
{ $code
"[ p ] [ q ] [ r ] tri*"
- ">r >r p r> q r> r"
+ "[ [ p ] dip q ] dip r"
}
} ;
"The following two lines are equivalent:"
{ $code
"[ p ] bi@"
- ">r p r> p"
+ "[ p ] dip p"
}
"The following two lines are also equivalent:"
{ $code
"The following two lines are equivalent:"
{ $code
"[ p ] 2bi@"
- ">r >r p r> r> p"
+ "[ p ] 2dip p"
}
"The following two lines are also equivalent:"
{ $code
"The following two lines are equivalent:"
{ $code
"[ p ] tri@"
- ">r >r p r> p r> p"
+ "[ [ p ] dip p ] dip p"
}
"The following two lines are also equivalent:"
{ $code
{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
{ $notes
- "The two quotations must leave the retain stack in the same state on exit as it was on entry, so the following code is not allowed:"
- { $code
- "[ 3 >r ] [ r> . ] compose"
- }
- "Except for this restriction, the following two lines are equivalent:"
+ "The following two lines are equivalent:"
{ $code
"compose call"
"append call"
{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." }
{ $notes
- "The three quotations must leave the retain stack in the same state on exit as it was on entry, so for example, the following code is not allowed:"
- { $code
- "[ >r ] swap [ r> ] 3compose"
- }
- "The correct way to achieve the effect of the above is the following:"
- { $code
- "[ dip ] curry"
- }
- "Excepting the retain stack restriction, the following two lines are equivalent:"
+ "The following two lines are equivalent:"
{ $code
"3compose call"
"3append call"
HELP: dip
{ $values { "x" object } { "quot" quotation } }
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." }
-{ $notes "The following are equivalent:"
- { $code ">r foo bar r>" }
- { $code "[ foo bar ] dip" }
+{ $examples
+ { $example "USING: arrays kernel math prettyprint ;" "10 20 30 [ / ] dip 2array ." "{ 1/2 30 }" }
} ;
HELP: 2dip
{ $values { "x" object } { "y" object } { "quot" quotation } }
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } " and " { $snippet "obj2" } " hidden on the retain stack." }
{ $notes "The following are equivalent:"
- { $code ">r >r foo bar r> r>" }
+ { $code "[ [ foo bar ] dip ] dip" }
{ $code "[ foo bar ] 2dip" }
} ;
{ $values { "x" object } { "y" object } { "z" object } { "quot" quotation } }
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } " hidden on the retain stack." }
{ $notes "The following are equivalent:"
- { $code ">r >r >r foo bar r> r> r>" }
+ { $code "[ [ [ foo bar ] dip ] dip ] dip" }
{ $code "[ foo bar ] 3dip" }
} ;
{ $subsection -rot }
{ $subsection spin }
{ $subsection roll }
-{ $subsection -roll }
-"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:"
-{ $subsection >r }
-{ $subsection r> }
-"The top of the data stack is ``hidden'' between " { $link >r } " and " { $link r> } ":"
-{ $example "1 2 3 >r .s r>" "1\n2" }
-"Usages of " { $link >r } " and " { $link r> } " must be balanced within a single quotation; quotations are not permitted to pop retain stack elements they did not push, or leave elements on the retain stack after returning."
-$nl
-"The " { $link "inference" } " tool checks retain stack usage. The " { $link "slip-keep-combinators" } " combinators abstract out common retain stack usage patterns." ;
+{ $subsection -roll } ;
ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
{ $subsection tri* }
"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
{ $code
- "! First alternative; uses retain stack explicitly"
- ">r >r 1 +"
- "r> 1 -"
- "r> 2 *"
+ "! First alternative; uses dip"
+ "[ [ 1 + ] dip 1 - dip ] 2 *"
"! Second alternative: uses tri*"
- "[ 1 + ]"
- "[ 1 - ]"
- "[ 2 * ] tri*"
+ "[ 1 + ] [ 1 - ] [ 2 * ] tri*"
}
$nl
{ $subsection both? }
{ $subsection either? } ;
-ARTICLE: "slip-keep-combinators" "The dip, slip and keep combinators"
+ARTICLE: "slip-keep-combinators" "Retain stack combinators"
+"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators."
+$nl
"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
{ $subsection dip }
{ $subsection 2dip }
"These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:"
{ $code
": keep ( x quot -- x )"
- " over >r call r> ; inline"
+ " over [ call ] dip ; inline"
}
"Word inlining is documented in " { $link "declarations" } "." ;
{ $subsection "booleans" }
{ $subsection "shuffle-words" }
"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
+{ $subsection "slip-keep-combinators" }
{ $subsection "cleave-combinators" }
{ $subsection "spread-combinators" }
{ $subsection "apply-combinators" }
-{ $subsection "slip-keep-combinators" }
{ $subsection "conditionals" }
{ $subsection "compositional-combinators" }
{ $subsection "combinators" }
! Regression
: (loop) ( a b c d -- )
- >r pick r> swap >r pick r> swap
- < [ >r >r >r 1+ r> r> r> (loop) ] [ 2drop 2drop ] if ; inline
+ [ pick ] dip swap [ pick ] dip swap
+ < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline
: loop ( obj obj -- )
- H{ } values swap >r dup length swap r> 0 -roll (loop) ;
+ H{ } values swap [ dup length swap ] dip 0 -roll (loop) ;
[ loop ] must-fail
USING: kernel.private slots.private classes.tuple.private ;
IN: kernel
+DEFER: dip
+DEFER: 2dip
+DEFER: 3dip
+
! Stack stuff
: spin ( x y z -- z y x ) swap rot ; inline
-: roll ( x y z t -- y z t x ) >r rot r> swap ; inline
+: roll ( x y z t -- y z t x ) [ rot ] dip swap ; inline
-: -roll ( x y z t -- t x y z ) swap >r -rot r> ; inline
+: -roll ( x y z t -- t x y z ) swap [ -rot ] dip ; inline
: 2over ( x y z -- x y z x y ) pick pick ; inline
pick [ roll 2drop call ] [ 2nip call ] if ; inline
! Slippers
-: slip ( quot x -- x ) >r call r> ; inline
+: slip ( quot x -- x ) [ call ] dip ;
-: 2slip ( quot x y -- x y ) >r >r call r> r> ; inline
+: 2slip ( quot x y -- x y ) [ call ] 2dip ;
-: 3slip ( quot x y z -- x y z ) >r >r >r call r> r> r> ; inline
+: 3slip ( quot x y z -- x y z ) [ call ] 3dip ;
: dip ( x quot -- x ) swap slip ; inline
-: 2dip ( x y quot -- x y ) swap >r dip r> ; inline
+: 2dip ( x y quot -- x y ) -rot 2slip ; inline
-: 3dip ( x y z quot -- x y z ) swap >r 2dip r> ; inline
+: 3dip ( x y z quot -- x y z ) -roll 3slip ; inline
! Keepers
-: keep ( x quot -- x ) dupd dip ; inline
+: keep ( x quot -- x ) over slip ; inline
-: 2keep ( x y quot -- x y ) >r 2dup r> 2dip ; inline
+: 2keep ( x y quot -- x y ) [ 2dup ] dip 2dip ; inline
-: 3keep ( x y z quot -- x y z ) >r 3dup r> 3dip ; inline
+: 3keep ( x y z quot -- x y z ) [ 3dup ] dip 3dip ; inline
! Cleavers
: bi ( x p q -- )
- >r keep r> call ; inline
+ [ keep ] dip call ; inline
: tri ( x p q r -- )
- >r >r keep r> keep r> call ; inline
+ [ [ keep ] dip keep ] dip call ; inline
! Double cleavers
: 2bi ( x y p q -- )
- >r 2keep r> call ; inline
+ [ 2keep ] dip call ; inline
: 2tri ( x y p q r -- )
- >r >r 2keep r> 2keep r> call ; inline
+ [ [ 2keep ] dip 2keep ] dip call ; inline
! Triple cleavers
: 3bi ( x y z p q -- )
- >r 3keep r> call ; inline
+ [ 3keep ] dip call ; inline
: 3tri ( x y z p q r -- )
- >r >r 3keep r> 3keep r> call ; inline
+ [ [ 3keep ] dip 3keep ] dip call ; inline
! Spreaders
: bi* ( x y p q -- )
- >r dip r> call ; inline
+ [ dip ] dip call ; inline
: tri* ( x y z p q r -- )
- >r >r 2dip r> dip r> call ; inline
+ [ [ 2dip ] dip dip ] dip call ; inline
! Double spreaders
: 2bi* ( w x y z p q -- )
- >r 2dip r> call ; inline
+ [ 2dip ] dip call ; inline
! Appliers
: bi@ ( x y quot -- )
dup slip swap [ loop ] [ drop ] if ; inline recursive
: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
- >r >r dup slip r> r> roll
- [ >r tuck 2slip r> while ]
+ [ dup slip ] 2dip roll
+ [ [ tuck 2slip ] dip while ]
[ 2nip call ] if ; inline recursive
! Object protocol
: either? ( x y quot -- ? ) bi@ or ; inline
: most ( x y quot -- z )
- >r 2dup r> call [ drop ] [ nip ] if ; inline
+ [ 2dup ] dip call [ drop ] [ nip ] if ; inline
! Error handling -- defined early so that other files can
! throw errors before continuations are loaded
lexer new-lexer ;
: skip ( i seq ? -- n )
- >r tuck r>
+ [ tuck ] dip
[ swap CHAR: \s eq? xor ] curry find-from drop
[ ] [ length ] ?if ;
M: fixnum - fixnum- ;
M: fixnum * fixnum* ;
M: fixnum /i fixnum/i ;
-M: fixnum /f >r >float r> >float float/f ;
+M: fixnum /f [ >float ] dip >float float/f ;
M: fixnum mod fixnum-mod ;
M: fixnum bit? neg shift 1 bitand 0 > ;
: (fixnum-log2) ( accum n -- accum )
- dup 1 number= [ drop ] [ >r 1+ r> 2/ (fixnum-log2) ] if ;
+ dup 1 number= [ drop ] [ [ 1+ ] [ 2/ ] bi* (fixnum-log2) ] if ;
inline recursive
M: fixnum (log2) 0 swap (fixnum-log2) ;
: pre-scale ( num den -- scale shifted-num scaled-den )
2dup [ log2 ] bi@ -
- tuck [ neg 54 + shift ] [ >r scale-denonimator r> + ] 2bi*
+ tuck [ neg 54 + shift ] [ [ scale-denonimator ] dip + ] 2bi*
-rot ; inline
! Second step: loop
: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
[ 2dup /i log2 53 > ]
- [ >r shift-mantissa r> ]
+ [ [ shift-mantissa ] dip ]
[ ] while /mod ; inline
! Third step: post-scaling
52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline
: scale-float ( scale mantissa -- float' )
- >r dup 0 < [ neg 2^ recip ] [ 2^ ] if r> * ; inline
+ [ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline
: post-scale ( scale mantissa -- n )
2/ dup log2 52 > [ shift-mantissa ] when
2dup >= [
drop
] [
- >r 1 shift r> (next-power-of-2)
+ [ 1 shift ] dip (next-power-of-2)
] if ;
: next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable
: iterate-prep 0 -rot ; inline
-: if-iterate? >r >r 2over < r> r> if ; inline
+: if-iterate? [ 2over < ] 2dip if ; inline
: iterate-step ( i n quot -- i n quot )
#! Apply quot to i, keep i and quot, hide n.
- swap >r 2dup 2slip r> swap ; inline
+ swap [ 2dup 2slip ] dip swap ; inline
-: iterate-next >r >r 1+ r> r> ; inline
+: iterate-next [ 1+ ] 2dip ; inline
PRIVATE>
2dup 2slip rot [
drop
] [
- >r 1- r> find-last-integer
+ [ 1- ] dip find-last-integer
] if
] if ; inline recursive
: (base>) ( str -- n ) radix get base> ;
: whole-part ( str -- m n )
- sign split1 >r (base>) r>
+ sign split1 [ (base>) ] dip
dup [ (base>) ] [ drop 0 swap ] if ;
: string>ratio ( str -- a/b )
"-" ?head dup negative? set swap
- "/" split1 (base>) >r whole-part r>
+ "/" split1 (base>) [ whole-part ] dip
3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ;
: valid-digits? ( seq -- ? )
{
{
[ CHAR: e over member? ]
- [ "e" split1 >r fix-float "e" r> 3append ]
+ [ "e" split1 [ fix-float "e" ] dip 3append ]
} {
[ CHAR: . over member? ]
[ ]
: off ( variable -- ) f swap set ; inline
: get-global ( variable -- value ) global at ;
: set-global ( value variable -- ) global set-at ;
-: change ( variable quot -- ) >r dup get r> rot slip set ; inline
+: change ( variable quot -- ) [ [ get ] keep ] dip dip set ; inline
: +@ ( n variable -- ) [ 0 or + ] change ;
: inc ( variable -- ) 1 swap +@ ; inline
: dec ( variable -- ) -1 swap +@ ; inline
H{ } clone >n call ndrop ; inline
: with-variable ( value key quot -- )
- >r associate >n r> call ndrop ; inline
+ [ associate >n ] dip call ndrop ; inline
: location ( -- loc )
file get lexer get line>> 2dup and
- [ >r path>> r> 2array ] [ 2drop f ] if ;
+ [ [ path>> ] dip 2array ] [ 2drop f ] if ;
: save-location ( definition -- )
location remember-definition ;
} cond ;
: (parse-until) ( accum end -- accum )
- dup >r parse-step [ r> (parse-until) ] [ r> drop ] if ;
+ [ parse-step ] keep swap [ (parse-until) ] [ drop ] if ;
: parse-until ( end -- vec )
100 <vector> swap (parse-until) ;
lexer-factory get call (parse-lines) ;
: parse-literal ( accum end quot -- accum )
- >r parse-until r> call parsed ; inline
+ [ parse-until ] dip call parsed ; inline
: parse-definition ( -- quot )
\ ; parse-until >quotation ;
M: curry length quot>> length 1+ ;
M: curry nth
- over zero? [ nip obj>> literalize ] [ >r 1- r> quot>> nth ] if ;
+ over 0 =
+ [ nip obj>> literalize ]
+ [ [ 1- ] dip quot>> nth ]
+ if ;
INSTANCE: curry immutable-sequence
GENERIC: clone-like ( seq exemplar -- newseq ) flushable
: new-like ( len exemplar quot -- seq )
- over >r >r new-sequence r> call r> like ; inline
+ over [ [ new-sequence ] dip call ] dip like ; inline
M: sequence like drop ;
[ first3-unsafe 3 ] [ nth-unsafe ] bi ; inline
: exchange-unsafe ( m n seq -- )
- [ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck
- >r >r set-nth-unsafe r> r> set-nth-unsafe ; inline
+ [ tuck [ nth-unsafe ] 2bi@ ]
+ [ tuck [ set-nth-unsafe ] 2bi@ ] 3bi ; inline
: (head) ( seq n -- from to seq ) 0 spin ; inline
: (tail) ( seq n -- from to seq ) over length rot ; inline
-: from-end >r dup length r> - ; inline
+: from-end [ dup length ] dip - ; inline
: (2sequence)
tuck 1 swap set-nth-unsafe
{ seq read-only } ;
: collapse-slice ( m n slice -- m' n' seq )
- [ from>> ] [ seq>> ] bi >r tuck + >r + r> r> ; inline
+ [ from>> ] [ seq>> ] bi [ tuck [ + ] 2bi@ ] dip ; inline
ERROR: slice-error from to seq reason ;
: prepare-subseq ( from to seq -- dst i src j n )
#! The check-length call forces partial dispatch
- [ >r swap - r> new-sequence dup 0 ] 3keep
+ [ [ swap - ] dip new-sequence dup 0 ] 3keep
-rot drop roll length check-length ; inline
: check-copy ( src n dst -- )
over 0 < [ bounds-error ] when
- >r swap length + r> lengthen ; inline
+ [ swap length + ] dip lengthen ; inline
PRIVATE>
: copy ( src i dst -- )
#! The check-length call forces partial dispatch
- pick length check-length >r 3dup check-copy spin 0 r>
+ pick length check-length [ 3dup check-copy spin 0 ] dip
(copy) drop ; inline
M: sequence clone-like
- >r dup length r> new-sequence [ 0 swap copy ] keep ;
+ [ dup length ] dip new-sequence [ 0 swap copy ] keep ;
M: immutable-sequence clone-like like ;
: 3append ( seq1 seq2 seq3 -- newseq ) pick 3append-as ;
: change-nth ( i seq quot -- )
- [ >r nth r> call ] 3keep drop set-nth ; inline
+ [ [ nth ] dip call ] 3keep drop set-nth ; inline
: min-length ( seq1 seq2 -- n ) [ length ] bi@ min ; inline
<PRIVATE
: (each) ( seq quot -- n quot' )
- >r dup length swap [ nth-unsafe ] curry r> compose ; inline
+ [ dup length swap [ nth-unsafe ] curry ] dip compose ; inline
: (collect) ( quot into -- quot' )
- [ >r keep r> set-nth-unsafe ] 2curry ; inline
+ [ [ keep ] dip set-nth-unsafe ] 2curry ; inline
: collect ( n quot into -- )
(collect) each-integer ; inline
: map-into ( seq quot into -- )
- >r (each) r> collect ; inline
+ [ (each) ] dip collect ; inline
: 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 )
- >r over r> nth-unsafe >r nth-unsafe r> ; inline
+ [ over ] dip nth-unsafe [ nth-unsafe ] dip ; inline
: (2each) ( seq1 seq2 quot -- n quot' )
- >r [ min-length ] 2keep r>
- [ >r 2nth-unsafe r> call ] 3curry ; inline
+ [ [ min-length ] 2keep ] dip
+ [ [ 2nth-unsafe ] dip call ] 3curry ; inline
: 2map-into ( seq1 seq2 quot into -- newseq )
- >r (2each) r> collect ; inline
+ [ (2each) ] dip collect ; inline
: finish-find ( i seq -- i elt )
over [ dupd nth-unsafe ] [ drop f ] if ; inline
: (find) ( seq quot quot' -- i elt )
- pick >r >r (each) r> call r> finish-find ; inline
+ pick [ [ (each) ] dip call ] dip finish-find ; inline
: (find-from) ( n seq quot quot' -- i elt )
[ 2dup bounds-check? ] 2dip
swapd each ; inline
: map-as ( seq quot exemplar -- newseq )
- >r over length r> [ [ map-into ] keep ] new-like ; inline
+ [ over length ] dip [ [ map-into ] keep ] new-like ; inline
: map ( seq quot -- newseq )
over map-as ; inline
[ drop ] prepose map ; inline
: replicate-as ( seq quot exemplar -- newseq )
- >r [ drop ] prepose r> map-as ; inline
+ [ [ drop ] prepose ] dip map-as ; inline
: change-each ( seq quot -- )
over map-into ; inline
(2each) each-integer ; inline
: 2reverse-each ( seq1 seq2 quot -- )
- >r [ <reversed> ] bi@ r> 2each ; inline
+ [ [ <reversed> ] bi@ ] dip 2each ; inline
: 2reduce ( seq1 seq2 identity quot -- result )
- >r -rot r> 2each ; inline
+ [ -rot ] dip 2each ; inline
: 2map-as ( seq1 seq2 quot exemplar -- newseq )
- >r 2over min-length r>
+ [ 2over min-length ] dip
[ [ 2map-into ] keep ] new-like ; inline
: 2map ( seq1 seq2 quot -- newseq )
[ nip find-last-integer ] (find-from) ; inline
: find-last ( seq quot -- i elt )
- [ >r 1- r> find-last-integer ] (find) ; inline
+ [ [ 1- ] dip find-last-integer ] (find) ; inline
: all? ( seq quot -- ? )
(each) all-integers? ; inline
: push-if ( elt quot accum -- )
- >r keep r> rot [ push ] [ 2drop ] if ; inline
+ [ keep ] dip rot [ push ] [ 2drop ] if ; inline
: pusher ( quot -- quot accum )
V{ } clone [ [ push-if ] 2curry ] keep ; inline
: filter ( seq quot -- subseq )
- over >r pusher >r each r> r> like ; inline
+ over [ pusher [ each ] dip ] dip like ; inline
: push-either ( elt quot accum1 accum2 -- )
- >r >r keep swap r> r> ? push ; inline
+ [ keep swap ] 2dip ? push ; inline
: 2pusher ( quot -- quot accum1 accum2 )
V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
: partition ( seq quot -- trueseq falseseq )
- over >r 2pusher >r >r each r> r> r> tuck [ like ] 2bi@ ; inline
+ over [ 2pusher [ each ] 2dip ] dip tuck [ like ] 2bi@ ; inline
: monotonic? ( seq quot -- ? )
- >r dup length 1- swap r> (monotonic) all? ; inline
+ [ dup length 1- swap ] dip (monotonic) all? ; inline
: interleave ( seq between quot -- )
- [ (interleave) ] 2curry >r dup length swap r> 2each ; inline
+ [ (interleave) ] 2curry [ dup length swap ] dip 2each ; inline
: accumulator ( quot -- quot' vec )
V{ } clone [ [ push ] curry compose ] keep ; inline
: produce-as ( pred quot tail exemplar -- seq )
- >r swap accumulator >r swap while r> r> like ; inline
+ [ swap accumulator [ swap while ] dip ] dip like ; inline
: produce ( pred quot tail -- seq )
{ } produce-as ; inline
: follow ( obj quot -- seq )
- >r [ dup ] r> [ keep ] curry [ ] produce nip ; inline
+ [ dup ] swap [ keep ] curry [ ] produce nip ; inline
: prepare-index ( seq quot -- seq n quot )
- >r dup length r> ; inline
+ [ dup length ] dip ; inline
: each-index ( seq quot -- )
prepare-index 2each ; inline
: cache-nth ( i seq quot -- elt )
2over ?nth dup [
- >r 3drop r>
+ [ 3drop ] dip
] [
- drop swap >r over >r call dup r> r> set-nth
+ drop swap [ over [ call dup ] dip ] dip set-nth
] if ; inline
: mismatch ( seq1 seq2 -- i )
[ eq? not ] with filter-here ;
: prefix ( seq elt -- newseq )
- over >r over length 1+ r> [
+ over [ over length 1+ ] dip [
[ 0 swap set-nth-unsafe ] keep
[ 1 swap copy ] keep
] new-like ;
: suffix ( seq elt -- newseq )
- over >r over length 1+ r> [
- [ >r over length r> set-nth-unsafe ] keep
+ over [ over length 1+ ] dip [
+ [ [ over length ] dip set-nth-unsafe ] keep
[ 0 swap copy ] keep
] new-like ;
2over = [
2drop 2drop
] [
- [ >r 2over + pick r> move >r 1+ r> ] keep
+ [ [ 2over + pick ] dip move [ 1+ ] dip ] keep
move-backward
] if ;
2over = [
2drop 2drop
] [
- [ >r pick >r dup dup r> + swap r> move 1- ] keep
+ [ [ pick [ dup dup ] dip + swap ] dip move 1- ] keep
move-forward
] if ;
: (open-slice) ( shift from to seq ? -- )
[
- >r [ 1- ] bi@ r> move-forward
+ [ [ 1- ] bi@ ] dip move-forward
] [
- >r >r over - r> r> move-backward
+ [ over - ] 2dip move-backward
] if ;
PRIVATE>
pick 0 = [
3drop
] [
- pick over length + over >r >r
- pick 0 > >r [ length ] keep r> (open-slice)
- r> r> set-length
+ pick over length + over
+ [ pick 0 > [ [ length ] keep ] dip (open-slice) ] 2dip
+ set-length
] if ;
: delete-slice ( from to seq -- )
- check-slice >r over >r - r> r> open-slice ;
+ check-slice [ over [ - ] dip ] dip open-slice ;
: delete-nth ( n seq -- )
- >r dup 1+ r> delete-slice ;
+ [ dup 1+ ] dip delete-slice ;
: replace-slice ( new from to seq -- )
- [ >r >r dup pick length + r> - over r> open-slice ] keep
+ [ [ [ dup pick length + ] dip - over ] dip open-slice ] keep
copy ;
: remove-nth ( n seq -- seq' )
: reverse-here ( seq -- )
dup length dup 2/ [
- >r 2dup r>
+ [ 2dup ] dip
tuck - 1- rot exchange-unsafe
] each 2drop ;
<PRIVATE
: joined-length ( seq glue -- n )
- >r dup sum-lengths swap length 1 [-] r> length * + ;
+ [ dup sum-lengths swap length 1 [-] ] dip length * + ;
PRIVATE>
>fixnum {
[ drop nip ]
[ 2drop first ]
- [ >r drop first2 r> call ]
- [ >r drop first3 r> bi@ ]
+ [ [ drop first2 ] dip call ]
+ [ [ drop first3 ] dip bi@ ]
} dispatch
] [
drop
- >r >r halves r> r>
+ [ halves ] 2dip
[ [ binary-reduce ] 2curry bi@ ] keep
call
] if ; inline recursive
: (start) ( subseq seq n -- subseq seq ? )
pick length [
- >r 3dup r> [ + swap nth-unsafe ] keep rot nth-unsafe =
+ [ 3dup ] dip [ + swap nth-unsafe ] keep rot nth-unsafe =
] all? nip ; inline
PRIVATE>
: start* ( subseq seq n -- i )
pick length pick length swap - 1+
[ (start) ] find-from
- swap >r 3drop r> ;
+ swap [ 3drop ] dip ;
: start ( subseq seq -- i ) 0 start* ; inline
: drop-prefix ( seq1 seq2 -- slice1 slice2 )
2dup mismatch [ 2dup min-length ] unless*
- tuck tail-slice >r tail-slice r> ;
+ tuck [ tail-slice ] 2bi@ ;
: unclip ( seq -- rest first )
[ rest ] [ first ] bi ;
inline
: trim-left-slice ( seq quot -- slice )
- over >r [ not ] compose find drop r> swap
+ over [ [ not ] compose find drop ] dip swap
[ tail-slice ] [ dup length tail-slice ] if* ; inline
: trim-left ( seq quot -- newseq )
over [ trim-left-slice ] dip like ; inline
: trim-right-slice ( seq quot -- slice )
- over >r [ not ] compose find-last drop r> swap
+ over [ [ not ] compose find-last drop ] dip swap
[ 1+ head-slice ] [ 0 head-slice ] if* ; inline
: trim-right ( seq quot -- newseq )
USING: arrays byte-arrays kernel kernel.private math namespaces
make sequences strings words effects generic generic.standard
classes classes.algebra slots.private combinators accessors
-words sequences.private assocs alien ;
+words sequences.private assocs alien quotations ;
IN: slots
TUPLE: slot-spec name offset class initial read-only ;
3bi ;
: create-accessor ( name effect -- word )
- >r "accessors" create dup r>
+ [ "accessors" create dup ] dip
"declared-effect" set-word-prop ;
: reader-quot ( slot-spec -- quot )
offset>> , \ set-slot , ;
: writer-quot/coerce ( slot-spec -- )
- [ \ >r , class>> "coercer" word-prop % \ r> , ]
+ [ class>> "coercer" word-prop [ dip ] curry % ]
[ offset>> , \ set-slot , ]
bi ;
bi ;
: writer-quot/fixnum ( slot-spec -- )
- [ >r >fixnum r> ] % writer-quot/check ;
+ [ [ >fixnum ] dip ] % writer-quot/check ;
: writer-quot ( slot-spec -- quot )
[
: define-changer ( name -- )
dup changer-word dup deferred? [
[
- [ over >r >r ] %
- over reader-word ,
- [ r> call r> swap ] %
+ \ over ,
+ over reader-word 1quotation
+ [ dip call ] curry [ dip swap ] curry %
swap setter-word ,
] [ ] make define-inline
] [ 2drop ] if ;
: dump ( from to seq accum -- )
#! Optimize common case where to - from = 1, 2, or 3.
- >r >r 2dup swap - r> r> pick 1 =
- [ >r >r 2drop r> nth-unsafe r> push ] [
+ [ 2dup swap - ] 2dip pick 1 =
+ [ [ [ 2drop ] dip nth-unsafe ] dip push ] [
pick 2 = [
- >r >r 2drop dup 1+
- r> [ nth-unsafe ] curry bi@
- r> [ push ] curry bi@
+ [
+ [ 2drop dup 1+ ] dip
+ [ nth-unsafe ] curry bi@
+ ] dip [ push ] curry bi@
] [
pick 3 = [
- >r >r 2drop dup 1+ dup 1+
- r> [ nth-unsafe ] curry tri@
- r> [ push ] curry tri@
- ] [
- >r nip subseq r> push-all
- ] if
+ [
+ [ 2drop dup 1+ dup 1+ ] dip
+ [ nth-unsafe ] curry tri@
+ ] dip [ push ] curry tri@
+ ] [ [ nip subseq ] dip push-all ] if
] if
] if ; inline
: split1 ( seq subseq -- before after )
dup pick start dup [
- [ >r over r> head -rot length ] keep + tail
+ [ [ over ] dip head -rot length ] keep + tail
] [
2drop f
] if ;
: split1-slice ( seq subseq -- before-slice after-slice )
dup pick start dup [
- [ >r over r> head-slice -rot length ] keep + tail-slice
+ [ [ over ] dip head-slice -rot length ] keep + tail-slice
] [
2drop f
] if ;
: unicode-escape ( str -- ch str' )
"{" ?head-slice [
CHAR: } over index cut-slice
- >r >string name>char-hook get call r>
+ [ >string name>char-hook get call ] dip
rest-slice
] [
- 6 cut-slice >r hex> r>
+ 6 cut-slice [ hex> ] dip
] if ;
: next-escape ( str -- ch str' )
: (parse-string) ( str -- m )
dup [ "\"\\" member? ] find dup [
- >r cut-slice >r % r> rest-slice r>
+ [ cut-slice [ % ] dip rest-slice ] dip
dup CHAR: " = [
drop from>>
] [
- drop next-escape >r , r> (parse-string)
+ drop next-escape [ , ] dip (parse-string)
] if
] [
"Unterminated string" throw
length>> ;
M: string nth-unsafe
- >r >fixnum r> string-nth ;
+ [ >fixnum ] dip string-nth ;
M: string set-nth-unsafe
dup reset-string-hashcode
- >r >fixnum >r >fixnum r> r> set-string-nth ;
+ [ [ >fixnum ] dip >fixnum ] dip set-string-nth ;
M: string clone
(clone) [ clone ] change-aux ;
"syntax" lookup t "delimiter" set-word-prop ;
: define-syntax ( name quot -- )
- >r "syntax" lookup dup r> define t "parsing" set-word-prop ;
+ [ "syntax" lookup dup ] dip define t "parsing" set-word-prop ;
[
{ "]" "}" ";" ">>" } [ define-delimiter ] each
] define-syntax
"INSTANCE:" [
- location >r
- scan-word scan-word 2dup add-mixin-instance
- <mixin-instance> r> remember-definition
+ location [
+ scan-word scan-word 2dup add-mixin-instance
+ <mixin-instance>
+ ] dip remember-definition
] define-syntax
"PREDICATE:" [
[ t ] [
V{ 1 2 3 4 } dup underlying>> length
- >r clone underlying>> length r>
+ [ clone underlying>> length ] dip
=
] unit-test
[ 4 ] [ 5 V{ 1 2 3 4 5 } index ] unit-test
[ t ] [
- 100 >array dup >vector <reversed> >array >r reverse r> =
+ 100 >array dup >vector <reversed> >array [ reverse ] dip =
] unit-test
[ fixnum ] [ 1 >bignum V{ } new-sequence length class ] unit-test
M: array (quot-uses) seq-uses ;
-M: hashtable (quot-uses) >r >alist r> seq-uses ;
+M: hashtable (quot-uses) [ >alist ] dip seq-uses ;
M: callable (quot-uses) seq-uses ;
-M: wrapper (quot-uses) >r wrapped>> r> (quot-uses) ;
+M: wrapper (quot-uses) [ wrapped>> ] dip (quot-uses) ;
: quot-uses ( quot -- assoc )
global [ H{ } clone [ (quot-uses) ] keep ] bind ;
dup [ 2nip ] [ drop <word> dup reveal ] if ;
: constructor-word ( name vocab -- word )
- >r "<" swap ">" 3append r> create ;
+ [ "<" swap ">" 3append ] dip create ;
PREDICATE: parsing-word < word "parsing" word-prop ;
&& array_nth(array,i + 1) == userenv[JIT_DISPATCH_WORD];
}
+bool jit_fast_dip_p(F_ARRAY *array, CELL i)
+{
+ return (i + 2) <= array_capacity(array)
+ && type_of(array_nth(array,i)) == QUOTATION_TYPE
+ && array_nth(array,i + 1) == userenv[JIT_DIP_WORD];
+}
+
+bool jit_fast_2dip_p(F_ARRAY *array, CELL i)
+{
+ return (i + 2) <= array_capacity(array)
+ && type_of(array_nth(array,i)) == QUOTATION_TYPE
+ && array_nth(array,i + 1) == userenv[JIT_2DIP_WORD];
+}
+
+bool jit_fast_3dip_p(F_ARRAY *array, CELL i)
+{
+ return (i + 2) <= array_capacity(array)
+ && type_of(array_nth(array,i)) == QUOTATION_TYPE
+ && array_nth(array,i + 1) == userenv[JIT_3DIP_WORD];
+}
+
bool jit_ignore_declare_p(F_ARRAY *array, CELL i)
{
return (i + 1) < array_capacity(array)
if(word->subprimitive == F && obj != userenv[JIT_DECLARE_WORD])
return true;
}
+ else if(type_of(obj) == QUOTATION_TYPE)
+ {
+ if(jit_fast_dip_p(array,i)
+ || jit_fast_2dip_p(array,i)
+ || jit_fast_3dip_p(array,i))
+ return true;
+ }
}
return false;
tail_call = true;
break;
}
+ else if(jit_fast_dip_p(untag_object(array),i))
+ {
+ GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
+ EMIT(userenv[JIT_DIP],literals_count - 1);
+
+ i++;
+ break;
+ }
+ else if(jit_fast_2dip_p(untag_object(array),i))
+ {
+ GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
+ EMIT(userenv[JIT_2DIP],literals_count - 1);
+
+ i++;
+ break;
+ }
+ else if(jit_fast_3dip_p(untag_object(array),i))
+ {
+ GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
+ EMIT(userenv[JIT_3DIP],literals_count - 1);
+
+ i++;
+ break;
+ }
case ARRAY_TYPE:
if(jit_fast_dispatch_p(untag_object(array),i))
{
tail_call = true;
break;
}
+ else if(jit_fast_dip_p(untag_object(array),i))
+ {
+ i++;
+ COUNT(userenv[JIT_DIP],i)
+ break;
+ }
+ else if(jit_fast_2dip_p(untag_object(array),i))
+ {
+ i++;
+ COUNT(userenv[JIT_2DIP],i)
+ break;
+ }
+ else if(jit_fast_3dip_p(untag_object(array),i))
+ {
+ i++;
+ COUNT(userenv[JIT_3DIP],i)
+ break;
+ }
case ARRAY_TYPE:
if(jit_fast_dispatch_p(untag_object(array),i))
{
JIT_PUSH_IMMEDIATE,
JIT_DECLARE_WORD = 42,
JIT_SAVE_STACK,
+ JIT_DIP_WORD,
+ JIT_DIP,
+ JIT_2DIP_WORD,
+ JIT_2DIP,
+ JIT_3DIP_WORD,
+ JIT_3DIP,
STACK_TRACES_ENV = 59,
projects / factor.git / commitdiff