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

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 2008-11-23 02:44:56 -06:00
parent 304ee19a3b
commit a4d9cdfeb3
54 changed files with 464 additions and 301 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
basis/bootstrap/image/image.factor
View File

@ -130,6 +130,12 @@ SYMBOL: jit-if-word
SYMBOL: jit-if-jump SYMBOL: jit-if-jump
SYMBOL: jit-dispatch-word SYMBOL: jit-dispatch-word
SYMBOL: jit-dispatch 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-epilog
SYMBOL: jit-return SYMBOL: jit-return
SYMBOL: jit-profiling SYMBOL: jit-profiling
@ -139,8 +145,8 @@ SYMBOL: jit-save-stack
! Default definition for undefined words ! Default definition for undefined words
SYMBOL: undefined-quot SYMBOL: undefined-quot
: userenv-offset ( symbol -- n ) : userenvs ( -- assoc )
{ H{
{ bootstrap-boot-quot 20 } { bootstrap-boot-quot 20 }
{ bootstrap-global 21 } { bootstrap-global 21 }
{ jit-code-format 22 } { jit-code-format 22 }
@ -160,8 +166,17 @@ SYMBOL: undefined-quot
{ jit-push-immediate 36 } { jit-push-immediate 36 }
{ jit-declare-word 42 } { jit-declare-word 42 }
{ jit-save-stack 43 } { 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 } { undefined-quot 60 }
} at header-size + ; } ; inline
: userenv-offset ( symbol -- n )
userenvs at header-size + ;
: emit ( cell -- ) image get push ; : emit ( cell -- ) image get push ;
@ -443,6 +458,9 @@ M: quotation '
\ dispatch jit-dispatch-word set \ dispatch jit-dispatch-word set
\ do-primitive jit-primitive-word set \ do-primitive jit-primitive-word set
\ declare jit-declare-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 [ undefined ] undefined-quot set
{ {
jit-code-format jit-code-format
@ -457,6 +475,12 @@ M: quotation '
jit-if-jump jit-if-jump
jit-dispatch-word jit-dispatch-word
jit-dispatch jit-dispatch
jit-dip-word
jit-dip
jit-2dip-word
jit-2dip
jit-3dip-word
jit-3dip
jit-epilog jit-epilog
jit-return jit-return
jit-profiling jit-profiling

1
basis/cpu/x86/32/bootstrap.factor
View File

@ -12,6 +12,7 @@ IN: bootstrap.x86
: mod-arg ( -- reg ) EDX ; : mod-arg ( -- reg ) EDX ;
: arg0 ( -- reg ) EAX ; : arg0 ( -- reg ) EAX ;
: arg1 ( -- reg ) EDX ; : arg1 ( -- reg ) EDX ;
: arg2 ( -- reg ) ECX ;
: temp-reg ( -- reg ) EBX ; : temp-reg ( -- reg ) EBX ;
: stack-reg ( -- reg ) ESP ; : stack-reg ( -- reg ) ESP ;
: ds-reg ( -- reg ) ESI ; : ds-reg ( -- reg ) ESI ;

1
basis/cpu/x86/64/unix/bootstrap.factor
View File

@ -7,6 +7,7 @@ IN: bootstrap.x86
: stack-frame-size ( -- n ) 4 bootstrap-cells ; : stack-frame-size ( -- n ) 4 bootstrap-cells ;
: arg0 ( -- reg ) RDI ; : arg0 ( -- reg ) RDI ;
: arg1 ( -- reg ) RSI ; : arg1 ( -- reg ) RSI ;
: arg2 ( -- reg ) RDX ;
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >> << "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
call call

1
basis/cpu/x86/64/winnt/bootstrap.factor
View File

@ -7,6 +7,7 @@ IN: bootstrap.x86
: stack-frame-size ( -- n ) 8 bootstrap-cells ; : stack-frame-size ( -- n ) 8 bootstrap-cells ;
: arg0 ( -- reg ) RCX ; : arg0 ( -- reg ) RCX ;
: arg1 ( -- reg ) RDX ; : arg1 ( -- reg ) RDX ;
: arg2 ( -- reg ) R8 ;
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >> << "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
call call

88
basis/cpu/x86/bootstrap.factor
View File

@ -73,6 +73,80 @@ big-endian off
arg0 quot-xt-offset [+] JMP ! execute branch arg0 quot-xt-offset [+] JMP ! execute branch
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define ] 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 stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
] f f f jit-epilog jit-define ] f f f jit-epilog jit-define
@ -223,19 +297,9 @@ big-endian off
ds-reg [] arg1 MOV ds-reg [] arg1 MOV
] f f f \ -rot define-sub-primitive ] f f f \ -rot define-sub-primitive
[ [ jit->r ] f f f \ >r 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
! Comparisons ! Comparisons
: jit-compare ( insn -- ) : jit-compare ( insn -- )

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

@ -87,6 +87,15 @@ M: composed infer-call*
M: object infer-call* M: object infer-call*
\ literal-expected inference-warning ; \ 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 ( -- ) : infer-curry ( -- )
2 consume-d 2 consume-d
dup first2 <curried> make-known dup first2 <curried> make-known
@ -150,6 +159,9 @@ M: object infer-call*
{ \ declare [ infer-declare ] } { \ declare [ infer-declare ] }
{ \ call [ pop-d infer-call ] } { \ call [ pop-d infer-call ] }
{ \ (call) [ pop-d infer-call ] } { \ (call) [ pop-d infer-call ] }
{ \ slip [ infer-slip ] }
{ \ 2slip [ infer-2slip ] }
{ \ 3slip [ infer-3slip ] }
{ \ curry [ infer-curry ] } { \ curry [ infer-curry ] }
{ \ compose [ infer-compose ] } { \ compose [ infer-compose ] }
{ \ execute [ infer-execute ] } { \ execute [ infer-execute ] }
@ -175,9 +187,10 @@ M: object infer-call*
(( value -- )) apply-word/effect ; (( value -- )) apply-word/effect ;
{ {
>r r> declare call (call) curry compose execute (execute) if >r r> declare call (call) slip 2slip 3slip curry compose
dispatch <tuple-boa> (throw) load-locals get-local drop-locals execute (execute) if dispatch <tuple-boa> (throw)
do-primitive alien-invoke alien-indirect alien-callback load-locals get-local drop-locals do-primitive alien-invoke
alien-indirect alien-callback
} [ t "special" set-word-prop ] each } [ t "special" set-word-prop ] each
{ call execute dispatch load-locals get-local drop-locals } { call execute dispatch load-locals get-local drop-locals }

4
core/arrays/arrays.factor
View File

@ -6,8 +6,8 @@ IN: arrays
M: array clone (clone) ; M: array clone (clone) ;
M: array length length>> ; M: array length length>> ;
M: array nth-unsafe >r >fixnum r> array-nth ; M: array nth-unsafe [ >fixnum ] dip array-nth ;
M: array set-nth-unsafe >r >fixnum r> set-array-nth ; M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ;
M: array resize resize-array ; M: array resize resize-array ;
: >array ( seq -- array ) { } clone-like ; : >array ( seq -- array ) { } clone-like ;

10
core/assocs/assocs.factor
View File

@ -86,7 +86,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
3drop f 3drop f
] [ ] [
3dup nth-unsafe at* 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 ] if ; inline recursive
: assoc-stack ( key seq -- value ) : assoc-stack ( key seq -- value )
@ -100,7 +100,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: assoc-hashcode ( n assoc -- code ) : 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>map hashcode* ;
: assoc-intersect ( assoc1 assoc2 -- intersection ) : assoc-intersect ( assoc1 assoc2 -- intersection )
@ -145,7 +145,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
[ 0 or + ] change-at ; [ 0 or + ] change-at ;
: map>assoc ( seq quot exemplar -- assoc ) : 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 ) : extract-keys ( seq assoc -- subassoc )
[ [ dupd at ] curry ] keep map>assoc ; [ [ dupd at ] curry ] keep map>assoc ;
@ -189,10 +189,10 @@ M: sequence delete-at
M: sequence assoc-size length ; M: sequence assoc-size length ;
M: sequence assoc-clone-like M: sequence assoc-clone-like
>r >alist r> clone-like ; [ >alist ] dip clone-like ;
M: sequence assoc-like M: sequence assoc-like
>r >alist r> like ; [ >alist ] dip like ;
M: sequence >alist ; M: sequence >alist ;

11
core/bootstrap/primitives.factor
View File

@ -129,8 +129,7 @@ bootstrapping? on
[ "slots" set-word-prop ] [ define-accessors ] 2bi ; [ "slots" set-word-prop ] [ define-accessors ] 2bi ;
: define-builtin ( symbol slotspec -- ) : define-builtin ( symbol slotspec -- )
>r [ define-builtin-predicate ] keep [ [ define-builtin-predicate ] keep ] dip define-builtin-slots ;
r> define-builtin-slots ;
"fixnum" "math" create register-builtin "fixnum" "math" create register-builtin
"bignum" "math" create register-builtin "bignum" "math" create register-builtin
@ -327,9 +326,7 @@ tuple
[ ] [ ]
[ [
[ [
\ >r , callable instance-check-quot [ dip ] curry %
callable instance-check-quot %
\ r> ,
callable instance-check-quot % callable instance-check-quot %
tuple-layout , tuple-layout ,
\ <tuple-boa> , \ <tuple-boa> ,
@ -389,7 +386,7 @@ tuple
! Primitive words ! Primitive words
: make-primitive ( word vocab n -- ) : make-primitive ( word vocab n -- )
>r create dup reset-word r> [ create dup reset-word ] dip
[ do-primitive ] curry [ ] like define ; [ do-primitive ] curry [ ] like define ;
{ {
@ -533,7 +530,7 @@ tuple
{ "unimplemented" "kernel.private" } { "unimplemented" "kernel.private" }
{ "gc-reset" "memory" } { "gc-reset" "memory" }
} }
[ >r first2 r> make-primitive ] each-index [ [ first2 ] dip make-primitive ] each-index
! Bump build number ! Bump build number
"build" "kernel" create build 1+ 1quotation define "build" "kernel" create build 1+ 1quotation define

11
core/checksums/checksums.factor
View File

@ -12,14 +12,17 @@ GENERIC: checksum-stream ( stream checksum -- value )
GENERIC: checksum-lines ( lines 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 ) : checksum-file ( path checksum -- value )
>r binary <file-reader> r> checksum-stream ; [ binary <file-reader> ] dip checksum-stream ;
: hex-string ( seq -- str ) : hex-string ( seq -- str )
[ >hex 2 CHAR: 0 pad-left ] { } map-as concat ; [ >hex 2 CHAR: 0 pad-left ] { } map-as concat ;

4
core/checksums/crc32/crc32.factor
View File

@ -11,7 +11,7 @@ IN: checksums.crc32
256 [ 256 [
8 [ 8 [
dup even? >r 2/ r> [ crc32-polynomial bitxor ] unless [ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless
] times >bignum ] times >bignum
] map 0 crc32-table copy ] map 0 crc32-table copy
@ -24,7 +24,7 @@ SINGLETON: crc32
INSTANCE: crc32 checksum 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 : finish-crc32 bitxor 4 >be ; inline

8
core/classes/algebra/algebra-tests.factor
View File

@ -13,9 +13,9 @@ IN: classes.algebra.tests
\ flatten-class must-infer \ flatten-class must-infer
\ flatten-builtin-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 ] [ object object object class-and* ] unit-test
[ t ] [ fixnum object fixnum 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 . 20 [ random-boolean-op ] [ ] replicate-as dup .
[ infer in>> [ random-boolean ] replicate dup . ] keep [ 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 ] unit-test

10
core/classes/algebra/algebra.factor
View File

@ -18,7 +18,7 @@ TUPLE: anonymous-complement class ;
C: <anonymous-complement> anonymous-complement C: <anonymous-complement> anonymous-complement
: 2cache ( key1 key2 assoc quot -- value ) : 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 -- ? ) GENERIC: valid-class? ( obj -- ? )
@ -66,13 +66,13 @@ DEFER: (class-or)
swap superclass dup [ swap class<= ] [ 2drop f ] if ; swap superclass dup [ swap class<= ] [ 2drop f ] if ;
: left-anonymous-union<= ( first second -- ? ) : left-anonymous-union<= ( first second -- ? )
>r members>> r> [ class<= ] curry all? ; [ members>> ] dip [ class<= ] curry all? ;
: right-anonymous-union<= ( first second -- ? ) : right-anonymous-union<= ( first second -- ? )
members>> [ class<= ] with contains? ; members>> [ class<= ] with contains? ;
: left-anonymous-intersection<= ( first second -- ? ) : left-anonymous-intersection<= ( first second -- ? )
>r participants>> r> [ class<= ] curry contains? ; [ participants>> ] dip [ class<= ] curry contains? ;
: right-anonymous-intersection<= ( first second -- ? ) : right-anonymous-intersection<= ( first second -- ? )
participants>> [ class<= ] with all? ; participants>> [ class<= ] with all? ;
@ -95,7 +95,7 @@ DEFER: (class-or)
} cond ; } cond ;
: left-anonymous-complement<= ( first second -- ? ) : left-anonymous-complement<= ( first second -- ? )
>r normalize-complement r> class<= ; [ normalize-complement ] dip class<= ;
PREDICATE: nontrivial-anonymous-complement < anonymous-complement PREDICATE: nontrivial-anonymous-complement < anonymous-complement
class>> { class>> {
@ -212,7 +212,7 @@ M: anonymous-complement (classes-intersect?)
: sort-classes ( seq -- newseq ) : sort-classes ( seq -- newseq )
[ [ name>> ] compare ] sort >vector [ [ name>> ] compare ] sort >vector
[ dup empty? not ] [ dup empty? not ]
[ dup largest-class >r over delete-nth r> ] [ dup largest-class [ over delete-nth ] dip ]
[ ] produce nip ; [ ] produce nip ;
: min-class ( class seq -- class/f ) : min-class ( class seq -- class/f )

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

@ -485,7 +485,7 @@ must-fail-with
[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test [ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
: accessor-exists? ( class name -- ? ) : 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 ; ">>" append "accessors" lookup method >boolean ;
[ t ] [ "x" accessor-exists? ] unit-test [ t ] [ "x" accessor-exists? ] unit-test

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

@ -58,7 +58,7 @@ PRIVATE>
: tuple>array ( tuple -- array ) : tuple>array ( tuple -- array )
prepare-tuple>array prepare-tuple>array
>r copy-tuple-slots r> [ copy-tuple-slots ] dip
first prefix ; first prefix ;
: tuple-slots ( tuple -- seq ) : tuple-slots ( tuple -- seq )
@ -178,9 +178,9 @@ ERROR: bad-superclass class ;
: update-slot ( old-values n class initial -- value ) : update-slot ( old-values n class initial -- value )
pick [ pick [
>r >r swap nth dup r> instance? r> swap [ [ swap nth dup ] dip instance? ] dip swap
[ drop ] [ nip ] if [ drop ] [ nip ] if
] [ >r 3drop r> ] if ; ] [ [ 3drop ] dip ] if ;
: apply-slot-permutation ( old-values triples -- new-values ) : apply-slot-permutation ( old-values triples -- new-values )
[ first3 update-slot ] with map ; [ first3 update-slot ] with map ;
@ -233,7 +233,7 @@ M: tuple-class update-class
class-usages [ tuple-class? ] filter ; class-usages [ tuple-class? ] filter ;
: each-subclass ( class quot -- ) : each-subclass ( class quot -- )
>r subclasses r> each ; inline [ subclasses ] dip each ; inline
: redefine-tuple-class ( class superclass slots -- ) : redefine-tuple-class ( class superclass slots -- )
[ [
@ -320,7 +320,7 @@ M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
M: tuple hashcode* M: tuple hashcode*
[ [
[ class hashcode ] [ tuple-size ] [ ] tri [ class hashcode ] [ tuple-size ] [ ] tri
>r rot r> [ [ rot ] dip [
swapd array-nth hashcode* sequence-hashcode-step swapd array-nth hashcode* sequence-hashcode-step
] 2curry each ] 2curry each
] recursive-hashcode ; ] recursive-hashcode ;

2
core/combinators/combinators-docs.factor
View File

@ -74,7 +74,7 @@ HELP: spread
{ $code { $code
"! Equivalent" "! Equivalent"
"{ [ p ] [ q ] [ r ] [ s ] } spread" "{ [ p ] [ q ] [ r ] [ s ] } spread"
">r >r >r p r> q r> r r> s" "[ [ [ p ] dip q ] dip r ] dip s"
} }
} ; } ;

12
core/combinators/combinators.factor
View File

@ -80,7 +80,7 @@ ERROR: no-case ;
drop [ swap adjoin ] curry each 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 ] each 2drop
] if ; ] if ;
@ -88,13 +88,13 @@ ERROR: no-case ;
next-power-of-2 swap [ nip clone ] curry map ; next-power-of-2 swap [ nip clone ] curry map ;
: distribute-buckets ( alist initial quot -- buckets ) : 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 [ length <buckets> dup ] keep
[ first2 (distribute-buckets) ] with each ; inline [ first2 (distribute-buckets) ] with each ; inline
: hash-case-table ( default assoc -- array ) : hash-case-table ( default assoc -- array )
V{ } [ 1array ] distribute-buckets 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 ) : hash-dispatch-quot ( table -- quot )
[ length 1- [ fixnum-bitand ] curry ] keep [ 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 [ length 4 <= ] [ [ word? ] contains? ] bi or ] [ drop linear-case-quot ] }
{ [ dup contiguous-range? ] [ drop dispatch-case-quot ] } { [ dup contiguous-range? ] [ drop dispatch-case-quot ] }
{ [ dup [ wrapper? ] contains? not ] [ drop hash-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 ] [ drop linear-case-quot ]
} cond ; } cond ;
! assert-depth ! assert-depth
: trim-datastacks ( seq1 seq2 -- seq1' seq2' ) : 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-underflow stack ;
ERROR: relative-overflow stack ; ERROR: relative-overflow stack ;
: assert-depth ( quot -- ) : assert-depth ( quot -- )
>r datastack r> dip >r datastack r> [ datastack ] dip dip [ datastack ] dip
2dup [ length ] compare { 2dup [ length ] compare {
{ +lt+ [ trim-datastacks nip relative-underflow ] } { +lt+ [ trim-datastacks nip relative-underflow ] }
{ +eq+ [ 2drop ] } { +eq+ [ 2drop ] }

2
core/compiler/errors/errors.factor
View File

@ -20,7 +20,7 @@ SYMBOL: with-compiler-errors?
: errors-of-type ( type -- assoc ) : errors-of-type ( type -- assoc )
compiler-errors get-global compiler-errors get-global
swap [ >r nip compiler-error-type r> eq? ] curry swap [ [ nip compiler-error-type ] dip eq? ] curry
assoc-filter ; assoc-filter ;
: compiler-errors. ( type -- ) : compiler-errors. ( type -- )

11
core/continuations/continuations.factor
View File

@ -65,7 +65,7 @@ C: <continuation> continuation
#! ( value f r:capture r:restore ) #! ( value f r:capture r:restore )
#! Execution begins right after the call to 'continuation'. #! Execution begins right after the call to 'continuation'.
#! The 'restore' branch is taken. #! 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 : callcc0 ( quot -- ) [ drop ] ifcc ; inline
@ -78,7 +78,7 @@ C: <continuation> continuation
set-catchstack set-catchstack
set-namestack set-namestack
set-retainstack set-retainstack
>r set-datastack r> [ set-datastack ] dip
set-callstack ; set-callstack ;
: (continue-with) ( obj continuation -- ) : (continue-with) ( obj continuation -- )
@ -87,7 +87,7 @@ C: <continuation> continuation
set-catchstack set-catchstack
set-namestack set-namestack
set-retainstack 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 ; set-callstack ;
PRIVATE> PRIVATE>
@ -135,14 +135,13 @@ SYMBOL: thread-error-hook
c> continue-with ; c> continue-with ;
: recover ( try recovery -- ) : 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 -- ) : ignore-errors ( quot -- )
[ drop ] recover ; inline [ drop ] recover ; inline
: cleanup ( try cleanup-always cleanup-error -- ) : cleanup ( try cleanup-always cleanup-error -- )
over >r compose [ dip rethrow ] curry [ compose [ dip rethrow ] curry recover ] [ drop ] 2bi call ; inline
recover r> call ; inline
ERROR: attempt-all-error ; ERROR: attempt-all-error ;

15
core/generic/math/math.factor
View File

@ -36,9 +36,10 @@ PREDICATE: math-class < class
: math-upgrade ( class1 class2 -- quot ) : math-upgrade ( class1 class2 -- quot )
[ math-class-max ] 2keep [ math-class-max ] 2keep
>r over r> (math-upgrade) >r (math-upgrade) [ over ] dip (math-upgrade) [
dup empty? [ [ dip ] curry [ ] like ] unless (math-upgrade)
r> append ; dup empty? [ [ dip ] curry [ ] like ] unless
] dip append ;
ERROR: no-math-method left right generic ; ERROR: no-math-method left right generic ;
@ -55,9 +56,9 @@ ERROR: no-math-method left right generic ;
: math-method ( word class1 class2 -- quot ) : math-method ( word class1 class2 -- quot )
2dup and [ 2dup and [
2dup math-upgrade >r 2dup math-upgrade
math-class-max over order min-class applicable-method [ math-class-max over order min-class applicable-method ] dip
r> prepend prepend
] [ ] [
2drop object-method 2drop object-method
] if ; ] if ;
@ -85,7 +86,7 @@ M: math-combination perform-combination
dup dup
\ over [ \ over [
dup math-class? [ dup math-class? [
\ dup [ >r 2dup r> math-method ] math-vtable \ dup [ [ 2dup ] dip math-method ] math-vtable
] [ ] [
over object-method over object-method
] if nip ] if nip

4
core/generic/standard/engines/engines.factor
View File

@ -18,7 +18,7 @@ GENERIC: engine>quot ( engine -- quot )
[ over assumed [ engine>quot ] with-variable ] assoc-map ; [ over assumed [ engine>quot ] with-variable ] assoc-map ;
: if-small? ( assoc true false -- ) : 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 ) : linear-dispatch-quot ( alist -- quot )
default get [ drop ] prepend swap default get [ drop ] prepend swap
@ -45,7 +45,7 @@ GENERIC: engine>quot ( engine -- quot )
{ 0 [ [ dup ] ] } { 0 [ [ dup ] ] }
{ 1 [ [ over ] ] } { 1 [ [ over ] ] }
{ 2 [ [ pick ] ] } { 2 [ [ pick ] ] }
[ 1- (picker) [ >r ] swap [ r> swap ] 3append ] [ 1- (picker) [ dip swap ] curry ]
} case ; } case ;
: picker ( -- quot ) \ (dispatch#) get (picker) ; : picker ( -- quot ) \ (dispatch#) get (picker) ;

2
core/generic/standard/engines/predicate/predicate.factor
View File

@ -10,7 +10,7 @@ TUPLE: predicate-dispatch-engine methods ;
C: <predicate-dispatch-engine> predicate-dispatch-engine C: <predicate-dispatch-engine> predicate-dispatch-engine
: class-predicates ( assoc -- assoc ) : class-predicates ( assoc -- assoc )
[ >r "predicate" word-prop picker prepend r> ] assoc-map ; [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ;
: keep-going? ( assoc -- ? ) : keep-going? ( assoc -- ? )
assumed get swap second first class<= ; assumed get swap second first class<= ;

6
core/generic/standard/engines/tag/tag.factor
View File

@ -26,7 +26,7 @@ C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
M: lo-tag-dispatch-engine engine>quot M: lo-tag-dispatch-engine engine>quot
methods>> engines>quots* methods>> engines>quots*
[ >r lo-tag-number r> ] assoc-map [ [ lo-tag-number ] dip ] assoc-map
[ [
picker % [ tag ] % [ picker % [ tag ] % [
sort-tags linear-dispatch-quot 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 M: hi-tag-dispatch-engine engine>quot
methods>> engines>quots* methods>> engines>quots*
[ >r hi-tag-number r> ] assoc-map [ [ hi-tag-number ] dip ] assoc-map
[ [
picker % hi-tag-quot % [ picker % hi-tag-quot % [
sort-tags linear-dispatch-quot sort-tags linear-dispatch-quot
] [ ] [
num-tags get , \ fixnum-fast , num-tags get , \ fixnum-fast ,
[ >r num-tags get - r> ] assoc-map [ [ num-tags get - ] dip ] assoc-map
num-hi-tags direct-dispatch-quot num-hi-tags direct-dispatch-quot
] if-small? % ] if-small? %
] [ ] make ; ] [ ] make ;

6
core/generic/standard/standard.factor
View File

@ -33,8 +33,8 @@ ERROR: no-method object generic ;
] change-at ; ] change-at ;
: flatten-method ( class method assoc -- ) : flatten-method ( class method assoc -- )
>r >r dup flatten-class keys swap r> r> [ [ dup flatten-class keys swap ] 2dip [
>r spin r> push-method [ spin ] dip push-method
] 3curry each ; ] 3curry each ;
: flatten-methods ( assoc -- assoc' ) : flatten-methods ( assoc -- assoc' )
@ -113,7 +113,7 @@ PREDICATE: simple-generic < standard-generic
T{ standard-combination f 0 } define-generic ; T{ standard-combination f 0 } define-generic ;
: with-standard ( combination quot -- quot' ) : with-standard ( combination quot -- quot' )
>r #>> (dispatch#) r> with-variable ; inline [ #>> (dispatch#) ] dip with-variable ; inline
M: standard-generic extra-values drop 0 ; M: standard-generic extra-values drop 0 ;

4
core/growable/growable.factor
View File

@ -43,10 +43,10 @@ M: growable set-length ( n seq -- )
growable-check growable-check
2dup length >= [ 2dup length >= [
2dup capacity >= [ over new-size over expand ] when 2dup capacity >= [ over new-size over expand ] when
>r >fixnum r> [ >fixnum ] dip
over 1 fixnum+fast over (>>length) over 1 fixnum+fast over (>>length)
] [ ] [
>r >fixnum r> [ >fixnum ] dip
] if ; inline ] if ; inline
M: growable set-nth ensure set-nth-unsafe ; M: growable set-nth ensure set-nth-unsafe ;

2
core/hashtables/hashtables-tests.factor
View File

@ -134,7 +134,7 @@ H{ } "x" set
[ H{ { -1 4 } { -3 16 } { -5 36 } } ] [ [ H{ { -1 4 } { -3 16 } { -5 36 } } ] [
H{ { 1 2 } { 3 4 } { 5 6 } } H{ { 1 2 } { 3 4 } { 5 6 } }
[ >r neg r> sq ] assoc-map [ [ neg ] dip sq ] assoc-map
] unit-test ] unit-test
! Bug discovered by littledan ! Bug discovered by littledan

17
core/hashtables/hashtables.factor
View File

@ -15,7 +15,7 @@ TUPLE: hashtable
length>> 1 fixnum-fast fixnum-bitand ; inline length>> 1 fixnum-fast fixnum-bitand ; inline
: hash@ ( key array -- i ) : 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 ) : probe ( array i -- array i )
2 fixnum+fast over wrap ; inline 2 fixnum+fast over wrap ; inline
@ -105,7 +105,7 @@ M: hashtable clear-assoc ( hash -- )
M: hashtable delete-at ( key hash -- ) M: hashtable delete-at ( key hash -- )
tuck key@ [ tuck key@ [
>r >r ((tombstone)) dup r> r> set-nth-pair [ ((tombstone)) dup ] 2dip set-nth-pair
hash-deleted+ hash-deleted+
] [ ] [
3drop 3drop
@ -115,9 +115,9 @@ M: hashtable assoc-size ( hash -- n )
[ count>> ] [ deleted>> ] bi - ; [ count>> ] [ deleted>> ] bi - ;
: rehash ( hash -- ) : rehash ( hash -- )
dup >alist >r dup >alist [
dup clear-assoc dup clear-assoc
r> (rehash) ; ] dip (rehash) ;
M: hashtable set-at ( value key hash -- ) M: hashtable set-at ( value key hash -- )
dup ?grow-hash dup ?grow-hash
@ -133,7 +133,7 @@ M: hashtable set-at ( value key hash -- )
: push-unsafe ( elt seq -- ) : push-unsafe ( elt seq -- )
[ length ] keep [ length ] keep
[ underlying>> set-array-nth ] [ underlying>> set-array-nth ]
[ >r 1+ r> (>>length) ] [ [ 1+ ] dip (>>length) ]
2bi ; inline 2bi ; inline
PRIVATE> PRIVATE>
@ -141,9 +141,10 @@ PRIVATE>
M: hashtable >alist M: hashtable >alist
[ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [ [ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [
[ [
>r [
>r 1 fixnum-shift-fast r> [ 1 fixnum-shift-fast ] dip
[ array-nth ] [ >r 1 fixnum+fast r> array-nth ] 2bi r> [ array-nth ] [ [ 1 fixnum+fast ] dip array-nth ] 2bi
] dip
pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if
] 2curry each ] 2curry each
] keep { } like ; ] keep { } like ;

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

@ -95,7 +95,7 @@ M: decoder stream-read-partial stream-read ;
: ((read-until)) ( buf quot: ( -- char stop? ) -- string/f sep/f ) : ((read-until)) ( buf quot: ( -- char stop? ) -- string/f sep/f )
dup call dup call
[ >r drop "" like r> ] [ [ drop "" like ] dip ]
[ pick push ((read-until)) ] if ; inline recursive [ pick push ((read-until)) ] if ; inline recursive
: (read-until) ( quot -- string/f sep/f ) : (read-until) ( quot -- string/f sep/f )

16
core/io/files/files.factor
View File

@ -26,13 +26,13 @@ HOOK: (file-appender) io-backend ( path -- stream )
<file-reader> lines ; <file-reader> lines ;
: with-file-reader ( path encoding quot -- ) : 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-contents ( path encoding -- str )
<file-reader> contents ; <file-reader> contents ;
: with-file-writer ( path encoding quot -- ) : 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 -- ) : set-file-lines ( seq path encoding -- )
[ [ print ] each ] with-file-writer ; [ [ print ] each ] with-file-writer ;
@ -41,7 +41,7 @@ HOOK: (file-appender) io-backend ( path -- stream )
[ write ] with-file-writer ; [ write ] with-file-writer ;
: with-file-appender ( path encoding quot -- ) : with-file-appender ( path encoding quot -- )
>r <file-appender> r> with-output-stream ; inline [ <file-appender> ] dip with-output-stream ; inline
! Pathnames ! Pathnames
: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ; : path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
@ -127,13 +127,13 @@ PRIVATE>
{ [ dup head.? ] [ rest trim-left-separators append-path ] } { [ dup head.? ] [ rest trim-left-separators append-path ] }
{ [ dup head..? ] [ { [ dup head..? ] [
2 tail trim-left-separators 2 tail trim-left-separators
>r parent-directory r> append-path [ parent-directory ] dip append-path
] } ] }
{ [ over absolute-path? over first path-separator? and ] [ { [ 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 trim-left-separators 3append
] ]
} cond ; } cond ;
@ -166,7 +166,7 @@ HOOK: make-link io-backend ( target symlink -- )
HOOK: read-link io-backend ( symlink -- path ) HOOK: read-link io-backend ( symlink -- path )
: copy-link ( target symlink -- ) : copy-link ( target symlink -- )
>r read-link r> make-link ; [ read-link ] dip make-link ;
SYMBOL: +regular-file+ SYMBOL: +regular-file+
SYMBOL: +directory+ SYMBOL: +directory+
@ -228,7 +228,7 @@ M: object normalize-path ( path -- path' )
(normalize-path) current-directory set ; (normalize-path) current-directory set ;
: with-directory ( path quot -- ) : with-directory ( path quot -- )
>r (normalize-path) current-directory r> with-variable ; inline [ (normalize-path) current-directory ] dip with-variable ; inline
! Creating directories ! Creating directories
HOOK: make-directory io-backend ( path -- ) HOOK: make-directory io-backend ( path -- )

6
core/io/io.factor
View File

@ -69,7 +69,7 @@ SYMBOL: error-stream
[ ] cleanup ; inline [ ] cleanup ; inline
: tabular-output ( style quot -- ) : 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 -- ) : with-row ( quot -- )
{ } make , ; inline { } make , ; inline
@ -89,8 +89,8 @@ SYMBOL: error-stream
] if ; inline ] if ; inline
: with-nesting ( style quot -- ) : with-nesting ( style quot -- )
>r output-stream get make-block-stream [ output-stream get make-block-stream ] dip
r> with-output-stream ; inline with-output-stream ; inline
: print ( string -- ) output-stream get stream-print ; : print ( string -- ) output-stream get stream-print ;

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

@ -6,11 +6,11 @@ IN: io.streams.byte-array
512 <byte-vector> swap <encoder> ; 512 <byte-vector> swap <encoder> ;
: with-byte-writer ( encoding quot -- byte-array ) : 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 dup encoder? [ stream>> ] when >byte-array ; inline
: <byte-reader> ( byte-array encoding -- stream ) : <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 -- ) : with-byte-reader ( byte-array encoding quot -- )
>r <byte-reader> r> with-input-stream* ; inline [ <byte-reader> ] dip with-input-stream* ; inline

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

@ -56,7 +56,7 @@ M: style-stream stream-write
[ style>> ] [ stream>> ] bi stream-format ; [ style>> ] [ stream>> ] bi stream-format ;
M: style-stream stream-write1 M: style-stream stream-write1
>r 1string r> stream-write ; [ 1string ] dip stream-write ;
M: style-stream make-span-stream M: style-stream make-span-stream
do-nested-style make-span-stream ; do-nested-style make-span-stream ;

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

@ -24,7 +24,7 @@ M: null-encoding decode-char drop stream-read1 ;
] unless ; ] unless ;
: map-last ( seq quot -- seq ) : map-last ( seq quot -- seq )
>r dup length <reversed> [ zero? ] r> compose 2map ; inline [ dup length <reversed> ] dip [ 0 = ] prepose 2map ; inline
PRIVATE> PRIVATE>
@ -75,7 +75,7 @@ M: growable stream-read-partial
>sbuf dup reverse-here null-encoding <decoder> ; >sbuf dup reverse-here null-encoding <decoder> ;
: with-string-reader ( str quot -- ) : with-string-reader ( str quot -- )
>r <string-reader> r> with-input-stream ; inline [ <string-reader> ] dip with-input-stream ; inline
INSTANCE: growable plain-writer INSTANCE: growable plain-writer

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

@ -29,12 +29,6 @@ HELP: spin $shuffle ;
HELP: roll $shuffle ; HELP: roll $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 ) HELP: datastack ( -- ds )
{ $values { "ds" array } } { $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." } ; { $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 HELP: keep
{ $values { "quot" { $quotation "( x -- )" } } { "x" object } } { $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 HELP: 2keep
{ $values { "quot" { $quotation "( x y -- )" } } { "x" object } { "y" object } } { $values { "quot" { $quotation "( x y -- )" } } { "x" object } { "y" object } }
@ -347,7 +344,7 @@ HELP: bi*
"The following two lines are equivalent:" "The following two lines are equivalent:"
{ $code { $code
"[ p ] [ q ] bi*" "[ p ] [ q ] bi*"
">r p r> q" "[ p ] dip q"
} }
} ; } ;
@ -358,7 +355,7 @@ HELP: 2bi*
"The following two lines are equivalent:" "The following two lines are equivalent:"
{ $code { $code
"[ p ] [ q ] 2bi*" "[ p ] [ q ] 2bi*"
">r >r p r> r> q" "[ p ] 2dip q"
} }
} ; } ;
@ -369,7 +366,7 @@ HELP: tri*
"The following two lines are equivalent:" "The following two lines are equivalent:"
{ $code { $code
"[ p ] [ q ] [ r ] tri*" "[ 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:" "The following two lines are equivalent:"
{ $code { $code
"[ p ] bi@" "[ p ] bi@"
">r p r> p" "[ p ] dip p"
} }
"The following two lines are also equivalent:" "The following two lines are also equivalent:"
{ $code { $code
@ -396,7 +393,7 @@ HELP: 2bi@
"The following two lines are equivalent:" "The following two lines are equivalent:"
{ $code { $code
"[ p ] 2bi@" "[ p ] 2bi@"
">r >r p r> r> p" "[ p ] 2dip p"
} }
"The following two lines are also equivalent:" "The following two lines are also equivalent:"
{ $code { $code
@ -412,7 +409,7 @@ HELP: tri@
"The following two lines are equivalent:" "The following two lines are equivalent:"
{ $code { $code
"[ p ] tri@" "[ p ] tri@"
">r >r p r> p r> p" "[ [ p ] dip p ] dip p"
} }
"The following two lines are also equivalent:" "The following two lines are also equivalent:"
{ $code { $code
@ -565,11 +562,7 @@ HELP: compose
{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } } { $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." } { $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
{ $notes { $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:" "The following two lines are equivalent:"
{ $code
"[ 3 >r ] [ r> . ] compose"
}
"Except for this restriction, the following two lines are equivalent:"
{ $code { $code
"compose call" "compose call"
"append call" "append call"
@ -589,15 +582,7 @@ HELP: 3compose
{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "compose" compose } } { $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" } "." } { $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." }
{ $notes { $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:" "The following two lines are equivalent:"
{ $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:"
{ $code { $code
"3compose call" "3compose call"
"3append call" "3append call"
@ -608,16 +593,15 @@ HELP: 3compose
HELP: dip HELP: dip
{ $values { "x" object } { "quot" quotation } } { $values { "x" object } { "quot" quotation } }
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." } { $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." }
{ $notes "The following are equivalent:" { $examples
{ $code ">r foo bar r>" } { $example "USING: arrays kernel math prettyprint ;" "10 20 30 [ / ] dip 2array ." "{ 1/2 30 }" }
{ $code "[ foo bar ] dip" }
} ; } ;
HELP: 2dip HELP: 2dip
{ $values { "x" object } { "y" object } { "quot" quotation } } { $values { "x" object } { "y" object } { "quot" quotation } }
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } " and " { $snippet "obj2" } " hidden on the retain stack." } { $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } " and " { $snippet "obj2" } " hidden on the retain stack." }
{ $notes "The following are equivalent:" { $notes "The following are equivalent:"
{ $code ">r >r foo bar r> r>" } { $code "[ [ foo bar ] dip ] dip" }
{ $code "[ foo bar ] 2dip" } { $code "[ foo bar ] 2dip" }
} ; } ;
@ -625,7 +609,7 @@ HELP: 3dip
{ $values { "x" object } { "y" object } { "z" object } { "quot" quotation } } { $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." } { $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } " hidden on the retain stack." }
{ $notes "The following are equivalent:" { $notes "The following are equivalent:"
{ $code ">r >r >r foo bar r> r> r>" } { $code "[ [ [ foo bar ] dip ] dip ] dip" }
{ $code "[ foo bar ] 3dip" } { $code "[ foo bar ] 3dip" }
} ; } ;
@ -692,15 +676,7 @@ $nl
{ $subsection -rot } { $subsection -rot }
{ $subsection spin } { $subsection spin }
{ $subsection roll } { $subsection roll }
{ $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." ;
ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators" 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 } "." "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* } { $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:" "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 { $code
"! First alternative; uses retain stack explicitly" "! First alternative; uses dip"
">r >r 1 +" "[ [ 1 + ] dip 1 - dip ] 2 *"
"r> 1 -"
"r> 2 *"
"! Second alternative: uses tri*" "! Second alternative: uses tri*"
"[ 1 + ]" "[ 1 + ] [ 1 - ] [ 2 * ] tri*"
"[ 1 - ]"
"[ 2 * ] tri*"
} }
$nl $nl
@ -819,7 +791,9 @@ $nl
{ $subsection both? } { $subsection both? }
{ $subsection either? } ; { $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:" "The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
{ $subsection dip } { $subsection dip }
{ $subsection 2dip } { $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:" "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 { $code
": keep ( x quot -- x )" ": keep ( x quot -- x )"
" over >r call r> ; inline" " over [ call ] dip ; inline"
} }
"Word inlining is documented in " { $link "declarations" } "." ; "Word inlining is documented in " { $link "declarations" } "." ;
@ -935,10 +909,10 @@ ARTICLE: "dataflow" "Data and control flow"
{ $subsection "booleans" } { $subsection "booleans" }
{ $subsection "shuffle-words" } { $subsection "shuffle-words" }
"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input." "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 "cleave-combinators" }
{ $subsection "spread-combinators" } { $subsection "spread-combinators" }
{ $subsection "apply-combinators" } { $subsection "apply-combinators" }
{ $subsection "slip-keep-combinators" }
{ $subsection "conditionals" } { $subsection "conditionals" }
{ $subsection "compositional-combinators" } { $subsection "compositional-combinators" }
{ $subsection "combinators" } { $subsection "combinators" }

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

@ -106,11 +106,11 @@ IN: kernel.tests
! Regression ! Regression
: (loop) ( a b c d -- ) : (loop) ( a b c d -- )
>r pick r> swap >r pick r> swap [ pick ] dip swap [ pick ] dip swap
< [ >r >r >r 1+ r> r> r> (loop) ] [ 2drop 2drop ] if ; inline < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline
: loop ( obj obj -- ) : 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 [ loop ] must-fail

48
core/kernel/kernel.factor
View File

@ -3,12 +3,16 @@
USING: kernel.private slots.private classes.tuple.private ; USING: kernel.private slots.private classes.tuple.private ;
IN: kernel IN: kernel
DEFER: dip
DEFER: 2dip
DEFER: 3dip
! Stack stuff ! Stack stuff
: spin ( x y z -- z y x ) swap rot ; inline : 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 : 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 pick [ roll 2drop call ] [ 2nip call ] if ; inline
! Slippers ! 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 : 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 ! 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 ! Cleavers
: bi ( x p q -- ) : bi ( x p q -- )
>r keep r> call ; inline [ keep ] dip call ; inline
: tri ( x p q r -- ) : tri ( x p q r -- )
>r >r keep r> keep r> call ; inline [ [ keep ] dip keep ] dip call ; inline
! Double cleavers ! Double cleavers
: 2bi ( x y p q -- ) : 2bi ( x y p q -- )
>r 2keep r> call ; inline [ 2keep ] dip call ; inline
: 2tri ( x y p q r -- ) : 2tri ( x y p q r -- )
>r >r 2keep r> 2keep r> call ; inline [ [ 2keep ] dip 2keep ] dip call ; inline
! Triple cleavers ! Triple cleavers
: 3bi ( x y z p q -- ) : 3bi ( x y z p q -- )
>r 3keep r> call ; inline [ 3keep ] dip call ; inline
: 3tri ( x y z p q r -- ) : 3tri ( x y z p q r -- )
>r >r 3keep r> 3keep r> call ; inline [ [ 3keep ] dip 3keep ] dip call ; inline
! Spreaders ! Spreaders
: bi* ( x y p q -- ) : bi* ( x y p q -- )
>r dip r> call ; inline [ dip ] dip call ; inline
: tri* ( x y z p q r -- ) : tri* ( x y z p q r -- )
>r >r 2dip r> dip r> call ; inline [ [ 2dip ] dip dip ] dip call ; inline
! Double spreaders ! Double spreaders
: 2bi* ( w x y z p q -- ) : 2bi* ( w x y z p q -- )
>r 2dip r> call ; inline [ 2dip ] dip call ; inline
! Appliers ! Appliers
: bi@ ( x y quot -- ) : bi@ ( x y quot -- )
@ -115,8 +119,8 @@ DEFER: if
dup slip swap [ loop ] [ drop ] if ; inline recursive dup slip swap [ loop ] [ drop ] if ; inline recursive
: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) : while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
>r >r dup slip r> r> roll [ dup slip ] 2dip roll
[ >r tuck 2slip r> while ] [ [ tuck 2slip ] dip while ]
[ 2nip call ] if ; inline recursive [ 2nip call ] if ; inline recursive
! Object protocol ! Object protocol
@ -182,7 +186,7 @@ GENERIC: boa ( ... class -- tuple )
: either? ( x y quot -- ? ) bi@ or ; inline : either? ( x y quot -- ? ) bi@ or ; inline
: most ( x y quot -- z ) : 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 ! Error handling -- defined early so that other files can
! throw errors before continuations are loaded ! throw errors before continuations are loaded

2
core/lexer/lexer.factor
View File

@ -23,7 +23,7 @@ TUPLE: lexer text line line-text line-length column ;
lexer new-lexer ; lexer new-lexer ;
: skip ( i seq ? -- n ) : skip ( i seq ? -- n )
>r tuck r> [ tuck ] dip
[ swap CHAR: \s eq? xor ] curry find-from drop [ swap CHAR: \s eq? xor ] curry find-from drop
[ ] [ length ] ?if ; [ ] [ length ] ?if ;

10
core/math/integers/integers.factor
View File

@ -25,7 +25,7 @@ M: fixnum + fixnum+ ;
M: fixnum - fixnum- ; M: fixnum - fixnum- ;
M: fixnum * fixnum* ; M: fixnum * fixnum* ;
M: fixnum /i fixnum/i ; 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 mod fixnum-mod ;
@ -41,7 +41,7 @@ M: fixnum bitnot fixnum-bitnot ;
M: fixnum bit? neg shift 1 bitand 0 > ; M: fixnum bit? neg shift 1 bitand 0 > ;
: (fixnum-log2) ( accum n -- accum ) : (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 inline recursive
M: fixnum (log2) 0 swap (fixnum-log2) ; 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 ) : pre-scale ( num den -- scale shifted-num scaled-den )
2dup [ log2 ] bi@ - 2dup [ log2 ] bi@ -
tuck [ neg 54 + shift ] [ >r scale-denonimator r> + ] 2bi* tuck [ neg 54 + shift ] [ [ scale-denonimator ] dip + ] 2bi*
-rot ; inline -rot ; inline
! Second step: loop ! Second step: loop
@ -103,7 +103,7 @@ M: bignum (log2) bignum-log2 ;
: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem ) : /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
[ 2dup /i log2 53 > ] [ 2dup /i log2 53 > ]
[ >r shift-mantissa r> ] [ [ shift-mantissa ] dip ]
[ ] while /mod ; inline [ ] while /mod ; inline
! Third step: post-scaling ! Third step: post-scaling
@ -111,7 +111,7 @@ M: bignum (log2) bignum-log2 ;
52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline 52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline
: scale-float ( scale mantissa -- float' ) : 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 ) : post-scale ( scale mantissa -- n )
2/ dup log2 52 > [ shift-mantissa ] when 2/ dup log2 52 > [ shift-mantissa ] when

10
core/math/math.factor
View File

@ -107,7 +107,7 @@ M: float fp-infinity? ( float -- ? )
2dup >= [ 2dup >= [
drop drop
] [ ] [
>r 1 shift r> (next-power-of-2) [ 1 shift ] dip (next-power-of-2)
] if ; ] if ;
: next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable : 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 : 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 ) : iterate-step ( i n quot -- i n quot )
#! Apply quot to i, keep i and quot, hide n. #! 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> PRIVATE>
@ -167,6 +167,6 @@ PRIVATE>
2dup 2slip rot [ 2dup 2slip rot [
drop drop
] [ ] [
>r 1- r> find-last-integer [ 1- ] dip find-last-integer
] if ] if
] if ; inline recursive ] if ; inline recursive

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

@ -51,12 +51,12 @@ SYMBOL: negative?
: (base>) ( str -- n ) radix get base> ; : (base>) ( str -- n ) radix get base> ;
: whole-part ( str -- m n ) : whole-part ( str -- m n )
sign split1 >r (base>) r> sign split1 [ (base>) ] dip
dup [ (base>) ] [ drop 0 swap ] if ; dup [ (base>) ] [ drop 0 swap ] if ;
: string>ratio ( str -- a/b ) : string>ratio ( str -- a/b )
"-" ?head dup negative? set swap "-" ?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 ; 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ;
: valid-digits? ( seq -- ? ) : valid-digits? ( seq -- ? )
@ -137,7 +137,7 @@ M: ratio >base
{ {
{ {
[ CHAR: e over member? ] [ CHAR: e over member? ]
[ "e" split1 >r fix-float "e" r> 3append ] [ "e" split1 [ fix-float "e" ] dip 3append ]
} { } {
[ CHAR: . over member? ] [ CHAR: . over member? ]
[ ] [ ]

4
core/namespaces/namespaces.factor
View File

@ -23,7 +23,7 @@ PRIVATE>
: off ( variable -- ) f swap set ; inline : off ( variable -- ) f swap set ; inline
: get-global ( variable -- value ) global at ; : get-global ( variable -- value ) global at ;
: set-global ( value variable -- ) global set-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 ; : +@ ( n variable -- ) [ 0 or + ] change ;
: inc ( variable -- ) 1 swap +@ ; inline : inc ( variable -- ) 1 swap +@ ; inline
: dec ( variable -- ) -1 swap +@ ; inline : dec ( variable -- ) -1 swap +@ ; inline
@ -37,4 +37,4 @@ PRIVATE>
H{ } clone >n call ndrop ; inline H{ } clone >n call ndrop ; inline
: with-variable ( value key quot -- ) : with-variable ( value key quot -- )
>r associate >n r> call ndrop ; inline [ associate >n ] dip call ndrop ; inline

6
core/parser/parser.factor
View File

@ -10,7 +10,7 @@ IN: parser
: location ( -- loc ) : location ( -- loc )
file get lexer get line>> 2dup and file get lexer get line>> 2dup and
[ >r path>> r> 2array ] [ 2drop f ] if ; [ [ path>> ] dip 2array ] [ 2drop f ] if ;
: save-location ( definition -- ) : save-location ( definition -- )
location remember-definition ; location remember-definition ;
@ -140,7 +140,7 @@ ERROR: staging-violation word ;
} cond ; } cond ;
: (parse-until) ( accum end -- accum ) : (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 ) : parse-until ( end -- vec )
100 <vector> swap (parse-until) ; 100 <vector> swap (parse-until) ;
@ -156,7 +156,7 @@ ERROR: staging-violation word ;
lexer-factory get call (parse-lines) ; lexer-factory get call (parse-lines) ;
: parse-literal ( accum end quot -- accum ) : parse-literal ( accum end quot -- accum )
>r parse-until r> call parsed ; inline [ parse-until ] dip call parsed ; inline
: parse-definition ( -- quot ) : parse-definition ( -- quot )
\ ; parse-until >quotation ; \ ; parse-until >quotation ;

5
core/quotations/quotations.factor
View File

@ -49,7 +49,10 @@ M: wrapper literalize <wrapper> ;
M: curry length quot>> length 1+ ; M: curry length quot>> length 1+ ;
M: curry nth 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 INSTANCE: curry immutable-sequence

116
core/sequences/sequences.factor
View File

@ -16,7 +16,7 @@ GENERIC: like ( seq exemplar -- newseq ) flushable
GENERIC: clone-like ( seq exemplar -- newseq ) flushable GENERIC: clone-like ( seq exemplar -- newseq ) flushable
: new-like ( len exemplar quot -- seq ) : 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 ; M: sequence like drop ;
@ -111,14 +111,14 @@ INSTANCE: integer immutable-sequence
[ first3-unsafe 3 ] [ nth-unsafe ] bi ; inline [ first3-unsafe 3 ] [ nth-unsafe ] bi ; inline
: exchange-unsafe ( m n seq -- ) : exchange-unsafe ( m n seq -- )
[ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck [ tuck [ nth-unsafe ] 2bi@ ]
>r >r set-nth-unsafe r> r> set-nth-unsafe ; inline [ tuck [ set-nth-unsafe ] 2bi@ ] 3bi ; inline
: (head) ( seq n -- from to seq ) 0 spin ; inline : (head) ( seq n -- from to seq ) 0 spin ; inline
: (tail) ( seq n -- from to seq ) over length rot ; 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) : (2sequence)
tuck 1 swap set-nth-unsafe tuck 1 swap set-nth-unsafe
@ -188,7 +188,7 @@ TUPLE: slice
{ seq read-only } ; { seq read-only } ;
: collapse-slice ( m n slice -- m' n' seq ) : 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 ; 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 ) : prepare-subseq ( from to seq -- dst i src j n )
#! The check-length call forces partial dispatch #! 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 -rot drop roll length check-length ; inline
: check-copy ( src n dst -- ) : check-copy ( src n dst -- )
over 0 < [ bounds-error ] when over 0 < [ bounds-error ] when
>r swap length + r> lengthen ; inline [ swap length + ] dip lengthen ; inline
PRIVATE> PRIVATE>
@ -279,11 +279,11 @@ PRIVATE>
: copy ( src i dst -- ) : copy ( src i dst -- )
#! The check-length call forces partial dispatch #! 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 (copy) drop ; inline
M: sequence clone-like 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 ; M: immutable-sequence clone-like like ;
@ -315,7 +315,7 @@ PRIVATE>
: 3append ( seq1 seq2 seq3 -- newseq ) pick 3append-as ; : 3append ( seq1 seq2 seq3 -- newseq ) pick 3append-as ;
: change-nth ( i seq quot -- ) : 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 : min-length ( seq1 seq2 -- n ) [ length ] bi@ min ; inline
@ -324,32 +324,32 @@ PRIVATE>
<PRIVATE <PRIVATE
: (each) ( seq quot -- n quot' ) : (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' ) : (collect) ( quot into -- quot' )
[ >r keep r> set-nth-unsafe ] 2curry ; inline [ [ keep ] dip set-nth-unsafe ] 2curry ; inline
: collect ( n quot into -- ) : collect ( n quot into -- )
(collect) each-integer ; inline (collect) each-integer ; inline
: map-into ( seq quot into -- ) : map-into ( seq quot into -- )
>r (each) r> collect ; inline [ (each) ] dip collect ; inline
: 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 ) : 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' ) : (2each) ( seq1 seq2 quot -- n quot' )
>r [ min-length ] 2keep r> [ [ min-length ] 2keep ] dip
[ >r 2nth-unsafe r> call ] 3curry ; inline [ [ 2nth-unsafe ] dip call ] 3curry ; inline
: 2map-into ( seq1 seq2 quot into -- newseq ) : 2map-into ( seq1 seq2 quot into -- newseq )
>r (2each) r> collect ; inline [ (2each) ] dip collect ; inline
: finish-find ( i seq -- i elt ) : finish-find ( i seq -- i elt )
over [ dupd nth-unsafe ] [ drop f ] if ; inline over [ dupd nth-unsafe ] [ drop f ] if ; inline
: (find) ( seq quot quot' -- i elt ) : (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 ) : (find-from) ( n seq quot quot' -- i elt )
[ 2dup bounds-check? ] 2dip [ 2dup bounds-check? ] 2dip
@ -373,7 +373,7 @@ PRIVATE>
swapd each ; inline swapd each ; inline
: map-as ( seq quot exemplar -- newseq ) : 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 ) : map ( seq quot -- newseq )
over map-as ; inline over map-as ; inline
@ -382,7 +382,7 @@ PRIVATE>
[ drop ] prepose map ; inline [ drop ] prepose map ; inline
: replicate-as ( seq quot exemplar -- newseq ) : replicate-as ( seq quot exemplar -- newseq )
>r [ drop ] prepose r> map-as ; inline [ [ drop ] prepose ] dip map-as ; inline
: change-each ( seq quot -- ) : change-each ( seq quot -- )
over map-into ; inline over map-into ; inline
@ -394,13 +394,13 @@ PRIVATE>
(2each) each-integer ; inline (2each) each-integer ; inline
: 2reverse-each ( seq1 seq2 quot -- ) : 2reverse-each ( seq1 seq2 quot -- )
>r [ <reversed> ] bi@ r> 2each ; inline [ [ <reversed> ] bi@ ] dip 2each ; inline
: 2reduce ( seq1 seq2 identity quot -- result ) : 2reduce ( seq1 seq2 identity quot -- result )
>r -rot r> 2each ; inline [ -rot ] dip 2each ; inline
: 2map-as ( seq1 seq2 quot exemplar -- newseq ) : 2map-as ( seq1 seq2 quot exemplar -- newseq )
>r 2over min-length r> [ 2over min-length ] dip
[ [ 2map-into ] keep ] new-like ; inline [ [ 2map-into ] keep ] new-like ; inline
: 2map ( seq1 seq2 quot -- newseq ) : 2map ( seq1 seq2 quot -- newseq )
@ -422,49 +422,49 @@ PRIVATE>
[ nip find-last-integer ] (find-from) ; inline [ nip find-last-integer ] (find-from) ; inline
: find-last ( seq quot -- i elt ) : find-last ( seq quot -- i elt )
[ >r 1- r> find-last-integer ] (find) ; inline [ [ 1- ] dip find-last-integer ] (find) ; inline
: all? ( seq quot -- ? ) : all? ( seq quot -- ? )
(each) all-integers? ; inline (each) all-integers? ; inline
: push-if ( elt quot accum -- ) : push-if ( elt quot accum -- )
>r keep r> rot [ push ] [ 2drop ] if ; inline [ keep ] dip rot [ push ] [ 2drop ] if ; inline
: pusher ( quot -- quot accum ) : pusher ( quot -- quot accum )
V{ } clone [ [ push-if ] 2curry ] keep ; inline V{ } clone [ [ push-if ] 2curry ] keep ; inline
: filter ( seq quot -- subseq ) : 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 -- ) : push-either ( elt quot accum1 accum2 -- )
>r >r keep swap r> r> ? push ; inline [ keep swap ] 2dip ? push ; inline
: 2pusher ( quot -- quot accum1 accum2 ) : 2pusher ( quot -- quot accum1 accum2 )
V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
: partition ( seq quot -- trueseq falseseq ) : 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 -- ? ) : 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 ( seq between quot -- )
[ (interleave) ] 2curry >r dup length swap r> 2each ; inline [ (interleave) ] 2curry [ dup length swap ] dip 2each ; inline
: accumulator ( quot -- quot' vec ) : accumulator ( quot -- quot' vec )
V{ } clone [ [ push ] curry compose ] keep ; inline V{ } clone [ [ push ] curry compose ] keep ; inline
: produce-as ( pred quot tail exemplar -- seq ) : 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 ( pred quot tail -- seq )
{ } produce-as ; inline { } produce-as ; inline
: follow ( obj quot -- seq ) : 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 ) : prepare-index ( seq quot -- seq n quot )
>r dup length r> ; inline [ dup length ] dip ; inline
: each-index ( seq quot -- ) : each-index ( seq quot -- )
prepare-index 2each ; inline prepare-index 2each ; inline
@ -518,9 +518,9 @@ PRIVATE>
: cache-nth ( i seq quot -- elt ) : cache-nth ( i seq quot -- elt )
2over ?nth dup [ 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 ] if ; inline
: mismatch ( seq1 seq2 -- i ) : mismatch ( seq1 seq2 -- i )
@ -575,14 +575,14 @@ PRIVATE>
[ eq? not ] with filter-here ; [ eq? not ] with filter-here ;
: prefix ( seq elt -- newseq ) : prefix ( seq elt -- newseq )
over >r over length 1+ r> [ over [ over length 1+ ] dip [
[ 0 swap set-nth-unsafe ] keep [ 0 swap set-nth-unsafe ] keep
[ 1 swap copy ] keep [ 1 swap copy ] keep
] new-like ; ] new-like ;
: suffix ( seq elt -- newseq ) : suffix ( seq elt -- newseq )
over >r over length 1+ r> [ over [ over length 1+ ] dip [
[ >r over length r> set-nth-unsafe ] keep [ [ over length ] dip set-nth-unsafe ] keep
[ 0 swap copy ] keep [ 0 swap copy ] keep
] new-like ; ] new-like ;
@ -596,7 +596,7 @@ PRIVATE>
2over = [ 2over = [
2drop 2drop 2drop 2drop
] [ ] [
[ >r 2over + pick r> move >r 1+ r> ] keep [ [ 2over + pick ] dip move [ 1+ ] dip ] keep
move-backward move-backward
] if ; ] if ;
@ -604,15 +604,15 @@ PRIVATE>
2over = [ 2over = [
2drop 2drop 2drop 2drop
] [ ] [
[ >r pick >r dup dup r> + swap r> move 1- ] keep [ [ pick [ dup dup ] dip + swap ] dip move 1- ] keep
move-forward move-forward
] if ; ] if ;
: (open-slice) ( shift from to seq ? -- ) : (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 ; ] if ;
PRIVATE> PRIVATE>
@ -621,19 +621,19 @@ PRIVATE>
pick 0 = [ pick 0 = [
3drop 3drop
] [ ] [
pick over length + over >r >r pick over length + over
pick 0 > >r [ length ] keep r> (open-slice) [ pick 0 > [ [ length ] keep ] dip (open-slice) ] 2dip
r> r> set-length set-length
] if ; ] if ;
: delete-slice ( from to seq -- ) : 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 -- ) : delete-nth ( n seq -- )
>r dup 1+ r> delete-slice ; [ dup 1+ ] dip delete-slice ;
: replace-slice ( new from to seq -- ) : 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 ; copy ;
: remove-nth ( n seq -- seq' ) : remove-nth ( n seq -- seq' )
@ -652,7 +652,7 @@ PRIVATE>
: reverse-here ( seq -- ) : reverse-here ( seq -- )
dup length dup 2/ [ dup length dup 2/ [
>r 2dup r> [ 2dup ] dip
tuck - 1- rot exchange-unsafe tuck - 1- rot exchange-unsafe
] each 2drop ; ] each 2drop ;
@ -679,7 +679,7 @@ PRIVATE>
<PRIVATE <PRIVATE
: joined-length ( seq glue -- n ) : joined-length ( seq glue -- n )
>r dup sum-lengths swap length 1 [-] r> length * + ; [ dup sum-lengths swap length 1 [-] ] dip length * + ;
PRIVATE> PRIVATE>
@ -735,12 +735,12 @@ PRIVATE>
>fixnum { >fixnum {
[ drop nip ] [ drop nip ]
[ 2drop first ] [ 2drop first ]
[ >r drop first2 r> call ] [ [ drop first2 ] dip call ]
[ >r drop first3 r> bi@ ] [ [ drop first3 ] dip bi@ ]
} dispatch } dispatch
] [ ] [
drop drop
>r >r halves r> r> [ halves ] 2dip
[ [ binary-reduce ] 2curry bi@ ] keep [ [ binary-reduce ] 2curry bi@ ] keep
call call
] if ; inline recursive ] if ; inline recursive
@ -755,7 +755,7 @@ PRIVATE>
: (start) ( subseq seq n -- subseq seq ? ) : (start) ( subseq seq n -- subseq seq ? )
pick length [ pick length [
>r 3dup r> [ + swap nth-unsafe ] keep rot nth-unsafe = [ 3dup ] dip [ + swap nth-unsafe ] keep rot nth-unsafe =
] all? nip ; inline ] all? nip ; inline
PRIVATE> PRIVATE>
@ -763,7 +763,7 @@ PRIVATE>
: start* ( subseq seq n -- i ) : start* ( subseq seq n -- i )
pick length pick length swap - 1+ pick length pick length swap - 1+
[ (start) ] find-from [ (start) ] find-from
swap >r 3drop r> ; swap [ 3drop ] dip ;
: start ( subseq seq -- i ) 0 start* ; inline : start ( subseq seq -- i ) 0 start* ; inline
@ -771,7 +771,7 @@ PRIVATE>
: drop-prefix ( seq1 seq2 -- slice1 slice2 ) : drop-prefix ( seq1 seq2 -- slice1 slice2 )
2dup mismatch [ 2dup min-length ] unless* 2dup mismatch [ 2dup min-length ] unless*
tuck tail-slice >r tail-slice r> ; tuck [ tail-slice ] 2bi@ ;
: unclip ( seq -- rest first ) : unclip ( seq -- rest first )
[ rest ] [ first ] bi ; [ rest ] [ first ] bi ;
@ -801,14 +801,14 @@ PRIVATE>
inline inline
: trim-left-slice ( seq quot -- slice ) : 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 [ tail-slice ] [ dup length tail-slice ] if* ; inline
: trim-left ( seq quot -- newseq ) : trim-left ( seq quot -- newseq )
over [ trim-left-slice ] dip like ; inline over [ trim-left-slice ] dip like ; inline
: trim-right-slice ( seq quot -- slice ) : 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 [ 1+ head-slice ] [ 0 head-slice ] if* ; inline
: trim-right ( seq quot -- newseq ) : trim-right ( seq quot -- newseq )

14
core/slots/slots.factor
View File

@ -3,7 +3,7 @@
USING: arrays byte-arrays kernel kernel.private math namespaces USING: arrays byte-arrays kernel kernel.private math namespaces
make sequences strings words effects generic generic.standard make sequences strings words effects generic generic.standard
classes classes.algebra slots.private combinators accessors classes classes.algebra slots.private combinators accessors
words sequences.private assocs alien ; words sequences.private assocs alien quotations ;
IN: slots IN: slots
TUPLE: slot-spec name offset class initial read-only ; TUPLE: slot-spec name offset class initial read-only ;
@ -23,7 +23,7 @@ PREDICATE: writer < word "writer" word-prop ;
3bi ; 3bi ;
: create-accessor ( name effect -- word ) : create-accessor ( name effect -- word )
>r "accessors" create dup r> [ "accessors" create dup ] dip
"declared-effect" set-word-prop ; "declared-effect" set-word-prop ;
: reader-quot ( slot-spec -- quot ) : reader-quot ( slot-spec -- quot )
@ -59,7 +59,7 @@ ERROR: bad-slot-value value class ;
offset>> , \ set-slot , ; offset>> , \ set-slot , ;
: writer-quot/coerce ( slot-spec -- ) : writer-quot/coerce ( slot-spec -- )
[ \ >r , class>> "coercer" word-prop % \ r> , ] [ class>> "coercer" word-prop [ dip ] curry % ]
[ offset>> , \ set-slot , ] [ offset>> , \ set-slot , ]
bi ; bi ;
@ -75,7 +75,7 @@ ERROR: bad-slot-value value class ;
bi ; bi ;
: writer-quot/fixnum ( slot-spec -- ) : writer-quot/fixnum ( slot-spec -- )
[ >r >fixnum r> ] % writer-quot/check ; [ [ >fixnum ] dip ] % writer-quot/check ;
: writer-quot ( slot-spec -- quot ) : writer-quot ( slot-spec -- quot )
[ [
@ -108,9 +108,9 @@ ERROR: bad-slot-value value class ;
: define-changer ( name -- ) : define-changer ( name -- )
dup changer-word dup deferred? [ dup changer-word dup deferred? [
[ [
[ over >r >r ] % \ over ,
over reader-word , over reader-word 1quotation
[ r> call r> swap ] % [ dip call ] curry [ dip swap ] curry %
swap setter-word , swap setter-word ,
] [ ] make define-inline ] [ ] make define-inline
] [ 2drop ] if ; ] [ 2drop ] if ;

22
core/sorting/sorting.factor
View File

@ -25,20 +25,20 @@ TUPLE: merge
: dump ( from to seq accum -- ) : dump ( from to seq accum -- )
#! Optimize common case where to - from = 1, 2, or 3. #! Optimize common case where to - from = 1, 2, or 3.
>r >r 2dup swap - r> r> pick 1 = [ 2dup swap - ] 2dip pick 1 =
[ >r >r 2drop r> nth-unsafe r> push ] [ [ [ [ 2drop ] dip nth-unsafe ] dip push ] [
pick 2 = [ pick 2 = [
>r >r 2drop dup 1+ [
r> [ nth-unsafe ] curry bi@ [ 2drop dup 1+ ] dip
r> [ push ] curry bi@ [ nth-unsafe ] curry bi@
] dip [ push ] curry bi@
] [ ] [
pick 3 = [ pick 3 = [
>r >r 2drop dup 1+ dup 1+ [
r> [ nth-unsafe ] curry tri@ [ 2drop dup 1+ dup 1+ ] dip
r> [ push ] curry tri@ [ nth-unsafe ] curry tri@
] [ ] dip [ push ] curry tri@
>r nip subseq r> push-all ] [ [ nip subseq ] dip push-all ] if
] if
] if ] if
] if ; inline ] if ; inline

4
core/splitting/splitting.factor
View File

@ -18,14 +18,14 @@ IN: splitting
: split1 ( seq subseq -- before after ) : split1 ( seq subseq -- before after )
dup pick start dup [ dup pick start dup [
[ >r over r> head -rot length ] keep + tail [ [ over ] dip head -rot length ] keep + tail
] [ ] [
2drop f 2drop f
] if ; ] if ;
: split1-slice ( seq subseq -- before-slice after-slice ) : split1-slice ( seq subseq -- before-slice after-slice )
dup pick start dup [ 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 2drop f
] if ; ] if ;

8
core/strings/parser/parser.factor
View File

@ -29,10 +29,10 @@ name>char-hook global [
: unicode-escape ( str -- ch str' ) : unicode-escape ( str -- ch str' )
"{" ?head-slice [ "{" ?head-slice [
CHAR: } over index cut-slice CHAR: } over index cut-slice
>r >string name>char-hook get call r> [ >string name>char-hook get call ] dip
rest-slice rest-slice
] [ ] [
6 cut-slice >r hex> r> 6 cut-slice [ hex> ] dip
] if ; ] if ;
: next-escape ( str -- ch str' ) : next-escape ( str -- ch str' )
@ -44,11 +44,11 @@ name>char-hook global [
: (parse-string) ( str -- m ) : (parse-string) ( str -- m )
dup [ "\"\\" member? ] find dup [ dup [ "\"\\" member? ] find dup [
>r cut-slice >r % r> rest-slice r> [ cut-slice [ % ] dip rest-slice ] dip
dup CHAR: " = [ dup CHAR: " = [
drop from>> drop from>>
] [ ] [
drop next-escape >r , r> (parse-string) drop next-escape [ , ] dip (parse-string)
] if ] if
] [ ] [
"Unterminated string" throw "Unterminated string" throw

4
core/strings/strings.factor
View File

@ -34,11 +34,11 @@ M: string length
length>> ; length>> ;
M: string nth-unsafe M: string nth-unsafe
>r >fixnum r> string-nth ; [ >fixnum ] dip string-nth ;
M: string set-nth-unsafe M: string set-nth-unsafe
dup reset-string-hashcode dup reset-string-hashcode
>r >fixnum >r >fixnum r> r> set-string-nth ; [ [ >fixnum ] dip >fixnum ] dip set-string-nth ;
M: string clone M: string clone
(clone) [ clone ] change-aux ; (clone) [ clone ] change-aux ;

9
core/syntax/syntax.factor
View File

@ -23,7 +23,7 @@ IN: bootstrap.syntax
"syntax" lookup t "delimiter" set-word-prop ; "syntax" lookup t "delimiter" set-word-prop ;
: define-syntax ( name quot -- ) : 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-delimiter ] each
@ -145,9 +145,10 @@ IN: bootstrap.syntax
] define-syntax ] define-syntax
"INSTANCE:" [ "INSTANCE:" [
location >r location [
scan-word scan-word 2dup add-mixin-instance scan-word scan-word 2dup add-mixin-instance
<mixin-instance> r> remember-definition <mixin-instance>
] dip remember-definition
] define-syntax ] define-syntax
"PREDICATE:" [ "PREDICATE:" [

4
core/vectors/vectors-tests.factor
View File

@ -71,7 +71,7 @@ IN: vectors.tests
[ t ] [ [ t ] [
V{ 1 2 3 4 } dup underlying>> length V{ 1 2 3 4 } dup underlying>> length
>r clone underlying>> length r> [ clone underlying>> length ] dip
= =
] unit-test ] unit-test
@ -91,7 +91,7 @@ IN: vectors.tests
[ 4 ] [ 5 V{ 1 2 3 4 5 } index ] unit-test [ 4 ] [ 5 V{ 1 2 3 4 5 } index ] unit-test
[ t ] [ [ t ] [
100 >array dup >vector <reversed> >array >r reverse r> = 100 >array dup >vector <reversed> >array [ reverse ] dip =
] unit-test ] unit-test
[ fixnum ] [ 1 >bignum V{ } new-sequence length class ] unit-test [ fixnum ] [ 1 >bignum V{ } new-sequence length class ] unit-test

6
core/words/words.factor
View File

@ -87,11 +87,11 @@ M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ;
M: array (quot-uses) seq-uses ; 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: 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 ) : quot-uses ( quot -- assoc )
global [ H{ } clone [ (quot-uses) ] keep ] bind ; global [ H{ } clone [ (quot-uses) ] keep ] bind ;
@ -239,7 +239,7 @@ ERROR: bad-create name vocab ;
dup [ 2nip ] [ drop <word> dup reveal ] if ; dup [ 2nip ] [ drop <word> dup reveal ] if ;
: constructor-word ( name vocab -- word ) : constructor-word ( name vocab -- word )
>r "<" swap ">" 3append r> create ; [ "<" swap ">" 3append ] dip create ;
PREDICATE: parsing-word < word "parsing" word-prop ; PREDICATE: parsing-word < word "parsing" word-prop ;

70
vm/quotations.c
View File

@ -54,6 +54,27 @@ bool jit_fast_dispatch_p(F_ARRAY *array, CELL i)
&& array_nth(array,i + 1) == userenv[JIT_DISPATCH_WORD]; && 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) bool jit_ignore_declare_p(F_ARRAY *array, CELL i)
{ {
return (i + 1) < array_capacity(array) 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]) if(word->subprimitive == F && obj != userenv[JIT_DECLARE_WORD])
return true; 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; return false;
@ -232,6 +260,30 @@ void jit_compile(CELL quot, bool relocate)
tail_call = true; tail_call = true;
break; 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: case ARRAY_TYPE:
if(jit_fast_dispatch_p(untag_object(array),i)) 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; tail_call = true;
break; 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: case ARRAY_TYPE:
if(jit_fast_dispatch_p(untag_object(array),i)) if(jit_fast_dispatch_p(untag_object(array),i))
{ {

6
vm/run.h
View File

@ -50,6 +50,12 @@ typedef enum {
JIT_PUSH_IMMEDIATE, JIT_PUSH_IMMEDIATE,
JIT_DECLARE_WORD = 42, JIT_DECLARE_WORD = 42,
JIT_SAVE_STACK, JIT_SAVE_STACK,
JIT_DIP_WORD,
JIT_DIP,
JIT_2DIP_WORD,
JIT_2DIP,
JIT_3DIP_WORD,
JIT_3DIP,
STACK_TRACES_ENV = 59, STACK_TRACES_ENV = 59,