Refactor all usages of >r/r> in core to use dip, 2dip, 3dip
Non-optimizing compiler now special-cases dip, 2dip, 3dip following a literal quotation: this allows us to break the dip/slip meta-circle without explicit calls to >r/r>db4
Slava Pestov
parent
304ee19a3b
commit
a4d9cdfeb3
|
|
@ -130,6 +130,12 @@ SYMBOL: jit-if-word
|
|||
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
|
||||
|
|
@ -139,8 +145,8 @@ SYMBOL: jit-save-stack
|
|||
! 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 }
|
||||
|
|
@ -160,8 +166,17 @@ SYMBOL: undefined-quot
|
|||
{ 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 ;
|
||||
|
||||
|
|
@ -443,6 +458,9 @@ M: quotation '
|
|||
\ 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
|
||||
|
|
@ -457,6 +475,12 @@ M: quotation '
|
|||
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
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ IN: bootstrap.x86
|
|||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ IN: bootstrap.x86
|
|||
: 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
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ IN: bootstrap.x86
|
|||
: 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
|
||||
|
|
|
|||
|
|
@ -73,6 +73,80 @@ big-endian off
|
|||
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
|
||||
|
|
@ -223,19 +297,9 @@ big-endian off
|
|||
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 -- )
|
||||
|
|
|
|||
|
|
@ -87,6 +87,15 @@ M: composed infer-call*
|
|||
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
|
||||
|
|
@ -150,6 +159,9 @@ M: object infer-call*
|
|||
{ \ 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 ] }
|
||||
|
|
@ -175,9 +187,10 @@ M: object infer-call*
|
|||
(( 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 }
|
||||
|
|
|
|||
|
|
@ -6,8 +6,8 @@ IN: arrays
|
|||
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -86,7 +86,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
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 )
|
||||
|
|
@ -100,7 +100,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
|
||||
: 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 )
|
||||
|
|
@ -145,7 +145,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
[ 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 ;
|
||||
|
|
@ -189,10 +189,10 @@ M: sequence delete-at
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -129,8 +129,7 @@ bootstrapping? on
|
|||
[ "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
|
||||
|
|
@ -327,9 +326,7 @@ tuple
|
|||
[ ]
|
||||
[
|
||||
[
|
||||
\ >r ,
|
||||
callable instance-check-quot %
|
||||
\ r> ,
|
||||
callable instance-check-quot [ dip ] curry %
|
||||
callable instance-check-quot %
|
||||
tuple-layout ,
|
||||
\ <tuple-boa> ,
|
||||
|
|
@ -389,7 +386,7 @@ tuple
|
|||
|
||||
! Primitive words
|
||||
: make-primitive ( word vocab n -- )
|
||||
>r create dup reset-word r>
|
||||
[ create dup reset-word ] dip
|
||||
[ do-primitive ] curry [ ] like define ;
|
||||
|
||||
{
|
||||
|
|
@ -533,7 +530,7 @@ tuple
|
|||
{ "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
|
||||
|
|
|
|||
|
|
@ -12,14 +12,17 @@ GENERIC: checksum-stream ( stream checksum -- value )
|
|||
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ IN: checksums.crc32
|
|||
|
||||
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
|
||||
|
||||
|
|
@ -24,7 +24,7 @@ SINGLETON: crc32
|
|||
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -13,9 +13,9 @@ IN: classes.algebra.tests
|
|||
\ flatten-class must-infer
|
||||
\ flatten-builtin-class must-infer
|
||||
|
||||
: class-and* ( cls1 cls2 cls3 -- ? ) >r class-and r> class= ;
|
||||
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
|
||||
|
||||
: class-or* ( cls1 cls2 cls3 -- ? ) >r class-or r> class= ;
|
||||
: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;
|
||||
|
||||
[ t ] [ object object object class-and* ] unit-test
|
||||
[ t ] [ fixnum object fixnum class-and* ] unit-test
|
||||
|
|
@ -240,9 +240,9 @@ UNION: z1 b1 c1 ;
|
|||
20 [ random-boolean-op ] [ ] replicate-as dup .
|
||||
[ infer in>> [ random-boolean ] replicate dup . ] keep
|
||||
|
||||
[ >r [ ] each r> call ] 2keep
|
||||
[ [ [ ] each ] dip call ] 2keep
|
||||
|
||||
>r [ boolean>class ] each r> [ boolean-op>class-op ] map call object class=
|
||||
[ [ boolean>class ] each ] dip [ boolean-op>class-op ] map call object class=
|
||||
|
||||
=
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ TUPLE: anonymous-complement class ;
|
|||
C: <anonymous-complement> anonymous-complement
|
||||
|
||||
: 2cache ( key1 key2 assoc quot -- value )
|
||||
>r >r 2array r> [ first2 ] r> compose cache ; inline
|
||||
[ 2array ] 2dip [ first2 ] prepose cache ; inline
|
||||
|
||||
GENERIC: valid-class? ( obj -- ? )
|
||||
|
||||
|
|
@ -66,13 +66,13 @@ DEFER: (class-or)
|
|||
swap superclass dup [ swap class<= ] [ 2drop f ] if ;
|
||||
|
||||
: left-anonymous-union<= ( first second -- ? )
|
||||
>r members>> r> [ class<= ] curry all? ;
|
||||
[ members>> ] dip [ class<= ] curry all? ;
|
||||
|
||||
: right-anonymous-union<= ( first second -- ? )
|
||||
members>> [ class<= ] with contains? ;
|
||||
|
||||
: left-anonymous-intersection<= ( first second -- ? )
|
||||
>r participants>> r> [ class<= ] curry contains? ;
|
||||
[ participants>> ] dip [ class<= ] curry contains? ;
|
||||
|
||||
: right-anonymous-intersection<= ( first second -- ? )
|
||||
participants>> [ class<= ] with all? ;
|
||||
|
|
@ -95,7 +95,7 @@ DEFER: (class-or)
|
|||
} cond ;
|
||||
|
||||
: left-anonymous-complement<= ( first second -- ? )
|
||||
>r normalize-complement r> class<= ;
|
||||
[ normalize-complement ] dip class<= ;
|
||||
|
||||
PREDICATE: nontrivial-anonymous-complement < anonymous-complement
|
||||
class>> {
|
||||
|
|
@ -212,7 +212,7 @@ M: anonymous-complement (classes-intersect?)
|
|||
: sort-classes ( seq -- newseq )
|
||||
[ [ name>> ] compare ] sort >vector
|
||||
[ dup empty? not ]
|
||||
[ dup largest-class >r over delete-nth r> ]
|
||||
[ dup largest-class [ over delete-nth ] dip ]
|
||||
[ ] produce nip ;
|
||||
|
||||
: min-class ( class seq -- class/f )
|
||||
|
|
|
|||
|
|
@ -485,7 +485,7 @@ must-fail-with
|
|||
[ 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
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ PRIVATE>
|
|||
|
||||
: tuple>array ( tuple -- array )
|
||||
prepare-tuple>array
|
||||
>r copy-tuple-slots r>
|
||||
[ copy-tuple-slots ] dip
|
||||
first prefix ;
|
||||
|
||||
: tuple-slots ( tuple -- seq )
|
||||
|
|
@ -178,9 +178,9 @@ ERROR: bad-superclass class ;
|
|||
|
||||
: 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 ;
|
||||
|
|
@ -233,7 +233,7 @@ M: tuple-class update-class
|
|||
class-usages [ tuple-class? ] filter ;
|
||||
|
||||
: each-subclass ( class quot -- )
|
||||
>r subclasses r> each ; inline
|
||||
[ subclasses ] dip each ; inline
|
||||
|
||||
: redefine-tuple-class ( class superclass slots -- )
|
||||
[
|
||||
|
|
@ -320,7 +320,7 @@ M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
|
|||
M: tuple hashcode*
|
||||
[
|
||||
[ class hashcode ] [ tuple-size ] [ ] tri
|
||||
>r rot r> [
|
||||
[ rot ] dip [
|
||||
swapd array-nth hashcode* sequence-hashcode-step
|
||||
] 2curry each
|
||||
] recursive-hashcode ;
|
||||
|
|
|
|||
|
|
@ -74,7 +74,7 @@ HELP: spread
|
|||
{ $code
|
||||
"! Equivalent"
|
||||
"{ [ p ] [ q ] [ r ] [ s ] } spread"
|
||||
">r >r >r p r> q r> r r> s"
|
||||
"[ [ [ p ] dip q ] dip r ] dip s"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -80,7 +80,7 @@ ERROR: no-case ;
|
|||
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 ;
|
||||
|
||||
|
|
@ -88,13 +88,13 @@ ERROR: no-case ;
|
|||
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
|
||||
|
|
@ -130,20 +130,20 @@ ERROR: no-case ;
|
|||
{ [ 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 ] }
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ SYMBOL: with-compiler-errors?
|
|||
|
||||
: 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 -- )
|
||||
|
|
|
|||
|
|
@ -65,7 +65,7 @@ C: <continuation> continuation
|
|||
#! ( 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
|
||||
|
||||
|
|
@ -78,7 +78,7 @@ C: <continuation> continuation
|
|||
set-catchstack
|
||||
set-namestack
|
||||
set-retainstack
|
||||
>r set-datastack r>
|
||||
[ set-datastack ] dip
|
||||
set-callstack ;
|
||||
|
||||
: (continue-with) ( obj continuation -- )
|
||||
|
|
@ -87,7 +87,7 @@ C: <continuation> 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>
|
||||
|
|
@ -135,14 +135,13 @@ SYMBOL: thread-error-hook
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -36,9 +36,10 @@ PREDICATE: math-class < class
|
|||
|
||||
: 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 ;
|
||||
|
||||
|
|
@ -55,9 +56,9 @@ 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 ;
|
||||
|
|
@ -85,7 +86,7 @@ M: math-combination perform-combination
|
|||
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
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ GENERIC: engine>quot ( engine -- quot )
|
|||
[ 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
|
||||
|
|
@ -45,7 +45,7 @@ GENERIC: engine>quot ( engine -- quot )
|
|||
{ 0 [ [ dup ] ] }
|
||||
{ 1 [ [ over ] ] }
|
||||
{ 2 [ [ pick ] ] }
|
||||
[ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
|
||||
[ 1- (picker) [ dip swap ] curry ]
|
||||
} case ;
|
||||
|
||||
: picker ( -- quot ) \ (dispatch#) get (picker) ;
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ TUPLE: predicate-dispatch-engine methods ;
|
|||
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<= ;
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
|
|||
|
||||
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
|
||||
|
|
@ -53,13 +53,13 @@ C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
|
|||
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -33,8 +33,8 @@ ERROR: no-method object generic ;
|
|||
] 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' )
|
||||
|
|
@ -113,7 +113,7 @@ PREDICATE: simple-generic < standard-generic
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -43,10 +43,10 @@ M: growable set-length ( n seq -- )
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -134,7 +134,7 @@ H{ } "x" set
|
|||
|
||||
[ 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
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ TUPLE: hashtable
|
|||
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
|
||||
|
|
@ -105,7 +105,7 @@ M: hashtable clear-assoc ( hash -- )
|
|||
|
||||
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
|
||||
|
|
@ -115,9 +115,9 @@ M: hashtable assoc-size ( hash -- n )
|
|||
[ 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
|
||||
|
|
@ -133,7 +133,7 @@ M: hashtable set-at ( value key hash -- )
|
|||
: push-unsafe ( elt seq -- )
|
||||
[ length ] keep
|
||||
[ underlying>> set-array-nth ]
|
||||
[ >r 1+ r> (>>length) ]
|
||||
[ [ 1+ ] dip (>>length) ]
|
||||
2bi ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
|
@ -141,9 +141,10 @@ 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 ;
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@ M: decoder stream-read-partial stream-read ;
|
|||
|
||||
: ((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 )
|
||||
|
|
|
|||
|
|
@ -26,13 +26,13 @@ HOOK: (file-appender) io-backend ( path -- stream )
|
|||
<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 ;
|
||||
|
|
@ -41,7 +41,7 @@ HOOK: (file-appender) io-backend ( path -- stream )
|
|||
[ 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? ;
|
||||
|
|
@ -127,13 +127,13 @@ PRIVATE>
|
|||
{ [ 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 ;
|
||||
|
|
@ -166,7 +166,7 @@ HOOK: make-link io-backend ( target symlink -- )
|
|||
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+
|
||||
|
|
@ -228,7 +228,7 @@ M: object normalize-path ( path -- path' )
|
|||
(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 -- )
|
||||
|
|
|
|||
|
|
@ -69,7 +69,7 @@ SYMBOL: error-stream
|
|||
[ ] 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
|
||||
|
|
@ -89,8 +89,8 @@ SYMBOL: error-stream
|
|||
] 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,11 +6,11 @@ IN: io.streams.byte-array
|
|||
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
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ M: style-stream stream-write
|
|||
[ 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 ;
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ M: null-encoding decode-char drop stream-read1 ;
|
|||
] unless ;
|
||||
|
||||
: map-last ( seq quot -- seq )
|
||||
>r dup length <reversed> [ zero? ] r> compose 2map ; inline
|
||||
[ dup length <reversed> ] dip [ 0 = ] prepose 2map ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -75,7 +75,7 @@ M: growable stream-read-partial
|
|||
>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
|
||||
|
||||
|
|
|
|||
|
|
@ -29,12 +29,6 @@ HELP: spin $shuffle ;
|
|||
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." } ;
|
||||
|
|
@ -212,7 +206,10 @@ HELP: 3slip
|
|||
|
||||
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 } }
|
||||
|
|
@ -347,7 +344,7 @@ HELP: bi*
|
|||
"The following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] bi*"
|
||||
">r p r> q"
|
||||
"[ p ] dip q"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
@ -358,7 +355,7 @@ HELP: 2bi*
|
|||
"The following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] 2bi*"
|
||||
">r >r p r> r> q"
|
||||
"[ p ] 2dip q"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
@ -369,7 +366,7 @@ HELP: tri*
|
|||
"The following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] [ r ] tri*"
|
||||
">r >r p r> q r> r"
|
||||
"[ [ p ] dip q ] dip r"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
@ -380,7 +377,7 @@ HELP: bi@
|
|||
"The following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] bi@"
|
||||
">r p r> p"
|
||||
"[ p ] dip p"
|
||||
}
|
||||
"The following two lines are also equivalent:"
|
||||
{ $code
|
||||
|
|
@ -396,7 +393,7 @@ HELP: 2bi@
|
|||
"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
|
||||
|
|
@ -412,7 +409,7 @@ HELP: tri@
|
|||
"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
|
||||
|
|
@ -565,11 +562,7 @@ HELP: compose
|
|||
{ $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"
|
||||
|
|
@ -589,15 +582,7 @@ HELP: 3compose
|
|||
{ $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"
|
||||
|
|
@ -608,16 +593,15 @@ HELP: 3compose
|
|||
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" }
|
||||
} ;
|
||||
|
||||
|
|
@ -625,7 +609,7 @@ HELP: 3dip
|
|||
{ $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" }
|
||||
} ;
|
||||
|
||||
|
|
@ -692,15 +676,7 @@ $nl
|
|||
{ $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 } "."
|
||||
|
|
@ -793,14 +769,10 @@ $nl
|
|||
{ $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
|
||||
|
|
@ -819,7 +791,9 @@ $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 }
|
||||
|
|
@ -851,7 +825,7 @@ ARTICLE: "implementing-combinators" "Implementing combinators"
|
|||
"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" } "." ;
|
||||
|
||||
|
|
@ -935,10 +909,10 @@ ARTICLE: "dataflow" "Data and control flow"
|
|||
{ $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" }
|
||||
|
|
|
|||
|
|
@ -106,11 +106,11 @@ IN: kernel.tests
|
|||
|
||||
! 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
|
||||
|
||||
|
|
|
|||
|
|
@ -3,12 +3,16 @@
|
|||
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
|
||||
|
||||
|
|
@ -49,56 +53,56 @@ DEFER: if
|
|||
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 -- )
|
||||
|
|
@ -115,8 +119,8 @@ DEFER: if
|
|||
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
|
||||
|
|
@ -182,7 +186,7 @@ GENERIC: boa ( ... class -- tuple )
|
|||
: 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
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ TUPLE: lexer text line line-text line-length column ;
|
|||
lexer new-lexer ;
|
||||
|
||||
: skip ( i seq ? -- n )
|
||||
>r tuck r>
|
||||
[ tuck ] dip
|
||||
[ swap CHAR: \s eq? xor ] curry find-from drop
|
||||
[ ] [ length ] ?if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ M: fixnum + fixnum+ ;
|
|||
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 ;
|
||||
|
||||
|
|
@ -41,7 +41,7 @@ M: fixnum bitnot fixnum-bitnot ;
|
|||
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) ;
|
||||
|
|
@ -94,7 +94,7 @@ M: bignum (log2) bignum-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
|
||||
|
|
@ -103,7 +103,7 @@ M: bignum (log2) bignum-log2 ;
|
|||
|
||||
: /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
|
||||
|
|
@ -111,7 +111,7 @@ M: bignum (log2) bignum-log2 ;
|
|||
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
|
||||
|
|
|
|||
|
|
@ -107,7 +107,7 @@ M: float fp-infinity? ( float -- ? )
|
|||
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
|
||||
|
|
@ -122,13 +122,13 @@ M: float fp-infinity? ( float -- ? )
|
|||
|
||||
: 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>
|
||||
|
||||
|
|
@ -167,6 +167,6 @@ PRIVATE>
|
|||
2dup 2slip rot [
|
||||
drop
|
||||
] [
|
||||
>r 1- r> find-last-integer
|
||||
[ 1- ] dip find-last-integer
|
||||
] if
|
||||
] if ; inline recursive
|
||||
|
|
|
|||
|
|
@ -51,12 +51,12 @@ SYMBOL: negative?
|
|||
: (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 -- ? )
|
||||
|
|
@ -137,7 +137,7 @@ M: ratio >base
|
|||
{
|
||||
{
|
||||
[ CHAR: e over member? ]
|
||||
[ "e" split1 >r fix-float "e" r> 3append ]
|
||||
[ "e" split1 [ fix-float "e" ] dip 3append ]
|
||||
} {
|
||||
[ CHAR: . over member? ]
|
||||
[ ]
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ PRIVATE>
|
|||
: 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
|
||||
|
|
@ -37,4 +37,4 @@ PRIVATE>
|
|||
H{ } clone >n call ndrop ; inline
|
||||
|
||||
: with-variable ( value key quot -- )
|
||||
>r associate >n r> call ndrop ; inline
|
||||
[ associate >n ] dip call ndrop ; inline
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: parser
|
|||
|
||||
: 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 ;
|
||||
|
|
@ -140,7 +140,7 @@ ERROR: staging-violation word ;
|
|||
} 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) ;
|
||||
|
|
@ -156,7 +156,7 @@ ERROR: staging-violation word ;
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -49,7 +49,10 @@ M: wrapper literalize <wrapper> ;
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ GENERIC: like ( seq exemplar -- newseq ) flushable
|
|||
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 ;
|
||||
|
||||
|
|
@ -111,14 +111,14 @@ INSTANCE: integer immutable-sequence
|
|||
[ 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
|
||||
|
|
@ -188,7 +188,7 @@ TUPLE: slice
|
|||
{ 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 ;
|
||||
|
||||
|
|
@ -253,12 +253,12 @@ INSTANCE: repetition immutable-sequence
|
|||
|
||||
: 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>
|
||||
|
||||
|
|
@ -279,11 +279,11 @@ 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 ;
|
||||
|
||||
|
|
@ -315,7 +315,7 @@ PRIVATE>
|
|||
: 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
|
||||
|
||||
|
|
@ -324,32 +324,32 @@ PRIVATE>
|
|||
<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
|
||||
|
|
@ -373,7 +373,7 @@ PRIVATE>
|
|||
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
|
||||
|
|
@ -382,7 +382,7 @@ PRIVATE>
|
|||
[ 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
|
||||
|
|
@ -394,13 +394,13 @@ PRIVATE>
|
|||
(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 )
|
||||
|
|
@ -422,49 +422,49 @@ PRIVATE>
|
|||
[ 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
|
||||
|
|
@ -518,9 +518,9 @@ PRIVATE>
|
|||
|
||||
: 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 )
|
||||
|
|
@ -575,14 +575,14 @@ PRIVATE>
|
|||
[ 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 ;
|
||||
|
||||
|
|
@ -596,7 +596,7 @@ PRIVATE>
|
|||
2over = [
|
||||
2drop 2drop
|
||||
] [
|
||||
[ >r 2over + pick r> move >r 1+ r> ] keep
|
||||
[ [ 2over + pick ] dip move [ 1+ ] dip ] keep
|
||||
move-backward
|
||||
] if ;
|
||||
|
||||
|
|
@ -604,15 +604,15 @@ PRIVATE>
|
|||
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>
|
||||
|
|
@ -621,19 +621,19 @@ 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' )
|
||||
|
|
@ -652,7 +652,7 @@ PRIVATE>
|
|||
|
||||
: reverse-here ( seq -- )
|
||||
dup length dup 2/ [
|
||||
>r 2dup r>
|
||||
[ 2dup ] dip
|
||||
tuck - 1- rot exchange-unsafe
|
||||
] each 2drop ;
|
||||
|
||||
|
|
@ -679,7 +679,7 @@ PRIVATE>
|
|||
<PRIVATE
|
||||
|
||||
: joined-length ( seq glue -- n )
|
||||
>r dup sum-lengths swap length 1 [-] r> length * + ;
|
||||
[ dup sum-lengths swap length 1 [-] ] dip length * + ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -735,12 +735,12 @@ 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
|
||||
|
|
@ -755,7 +755,7 @@ PRIVATE>
|
|||
|
||||
: (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>
|
||||
|
|
@ -763,7 +763,7 @@ 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
|
||||
|
||||
|
|
@ -771,7 +771,7 @@ PRIVATE>
|
|||
|
||||
: 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 ;
|
||||
|
|
@ -801,14 +801,14 @@ PRIVATE>
|
|||
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 )
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
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 ;
|
||||
|
|
@ -23,7 +23,7 @@ PREDICATE: writer < word "writer" word-prop ;
|
|||
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 )
|
||||
|
|
@ -59,7 +59,7 @@ ERROR: bad-slot-value value class ;
|
|||
offset>> , \ set-slot , ;
|
||||
|
||||
: writer-quot/coerce ( slot-spec -- )
|
||||
[ \ >r , class>> "coercer" word-prop % \ r> , ]
|
||||
[ class>> "coercer" word-prop [ dip ] curry % ]
|
||||
[ offset>> , \ set-slot , ]
|
||||
bi ;
|
||||
|
||||
|
|
@ -75,7 +75,7 @@ ERROR: bad-slot-value value class ;
|
|||
bi ;
|
||||
|
||||
: writer-quot/fixnum ( slot-spec -- )
|
||||
[ >r >fixnum r> ] % writer-quot/check ;
|
||||
[ [ >fixnum ] dip ] % writer-quot/check ;
|
||||
|
||||
: writer-quot ( slot-spec -- quot )
|
||||
[
|
||||
|
|
@ -108,9 +108,9 @@ ERROR: bad-slot-value value class ;
|
|||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -25,20 +25,20 @@ TUPLE: merge
|
|||
|
||||
: 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
|
||||
|
||||
|
|
|
|||
|
|
@ -18,14 +18,14 @@ IN: splitting
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -29,10 +29,10 @@ name>char-hook global [
|
|||
: 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' )
|
||||
|
|
@ -44,11 +44,11 @@ name>char-hook global [
|
|||
|
||||
: (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
|
||||
|
|
|
|||
|
|
@ -34,11 +34,11 @@ M: string length
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ IN: bootstrap.syntax
|
|||
"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
|
||||
|
|
@ -145,9 +145,10 @@ IN: bootstrap.syntax
|
|||
] 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:" [
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ IN: vectors.tests
|
|||
|
||||
[ t ] [
|
||||
V{ 1 2 3 4 } dup underlying>> length
|
||||
>r clone underlying>> length r>
|
||||
[ clone underlying>> length ] dip
|
||||
=
|
||||
] unit-test
|
||||
|
||||
|
|
@ -91,7 +91,7 @@ IN: vectors.tests
|
|||
[ 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
|
||||
|
|
|
|||
|
|
@ -87,11 +87,11 @@ M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ;
|
|||
|
||||
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 ;
|
||||
|
|
@ -239,7 +239,7 @@ ERROR: bad-create name vocab ;
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -54,6 +54,27 @@ bool jit_fast_dispatch_p(F_ARRAY *array, CELL i)
|
|||
&& 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)
|
||||
|
|
@ -115,6 +136,13 @@ bool jit_stack_frame_p(F_ARRAY *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;
|
||||
|
|
@ -232,6 +260,30 @@ void jit_compile(CELL quot, bool relocate)
|
|||
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))
|
||||
{
|
||||
|
|
@ -366,6 +418,24 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
|
|||
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))
|
||||
{
|
||||
|
|
|
|||
Loading…
Reference in New Issue