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

add a few usages of iota, remove most 1+ and 1- from core

db4
Doug Coleman 2009-05-01 19:58:24 -05:00
parent ce7ad9a42d
commit 0ad6d1fb7b
27 changed files with 77 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/random/random.factor
View File

@ -54,7 +54,7 @@ PRIVATE>
: randomize ( seq -- seq ) : randomize ( seq -- seq )
dup length [ dup 1 > ] dup length [ dup 1 > ]
[ [ random ] [ 1- ] bi [ pick exchange ] keep ] [ [ iota random ] [ 1- ] bi [ pick exchange ] keep ]
while drop ; while drop ;
: delete-random ( seq -- elt ) : delete-random ( seq -- elt )

4
core/assocs/assocs.factor
View File

@ -32,7 +32,7 @@ M: assoc assoc-like drop ;
3drop f 3drop f
] [ ] [
3dup nth-unsafe at* 3dup nth-unsafe at*
[ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if [ [ 3drop ] dip ] [ drop [ 1 - ] dip (assoc-stack) ] if
] if ; inline recursive ] if ; inline recursive
: search-alist ( key alist -- pair/f i/f ) : search-alist ( key alist -- pair/f i/f )
@ -105,7 +105,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
assoc-size 0 = ; assoc-size 0 = ;
: assoc-stack ( key seq -- value ) : assoc-stack ( key seq -- value )
[ length 1- ] keep (assoc-stack) ; flushable [ length 1 - ] keep (assoc-stack) ; flushable
: assoc-subset? ( assoc1 assoc2 -- ? ) : assoc-subset? ( assoc1 assoc2 -- ? )
[ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ; [ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ;

2
core/bootstrap/primitives.factor
View File

@ -513,4 +513,4 @@ tuple
} [ [ first3 ] dip swap make-primitive ] each-index } [ [ first3 ] dip swap make-primitive ] each-index
! Bump build number ! Bump build number
"build" "kernel" create build 1+ [ ] curry (( -- n )) define-declared "build" "kernel" create build 1 + [ ] curry (( -- n )) define-declared

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

@ -9,7 +9,7 @@ CONSTANT: crc32-polynomial HEX: edb88320
CONSTANT: crc32-table V{ } CONSTANT: crc32-table V{ }
256 [ 256 iota [
8 [ 8 [
[ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless [ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless
] times >bignum ] times >bignum

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

@ -254,7 +254,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
" } ;" " } ;"
"" ""
": next-position ( role -- newrole )" ": next-position ( role -- newrole )"
" positions [ index 1+ ] keep nth ;" " positions [ index 1 + ] keep nth ;"
"" ""
": promote ( employee -- employee )" ": promote ( employee -- employee )"
" [ 1.2 * ] change-salary" " [ 1.2 * ] change-salary"

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

@ -165,7 +165,7 @@ ERROR: bad-superclass class ;
{ {
[ , ] [ , ]
[ [ superclass class-size ] [ "slots" word-prop length ] bi + , ] [ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
[ superclasses length 1- , ] [ superclasses length 1 - , ]
[ superclasses [ [ , ] [ hashcode , ] bi ] each ] [ superclasses [ [ , ] [ hashcode , ] bi ] each ]
} cleave } cleave
] { } make ; ] { } make ;
@ -331,7 +331,7 @@ GENERIC: tuple-hashcode ( n tuple -- x )
M: tuple tuple-hashcode M: tuple tuple-hashcode
[ [
[ class hashcode ] [ tuple-size ] [ ] tri [ class hashcode ] [ tuple-size iota ] [ ] tri
[ rot ] dip [ [ rot ] dip [
swapd array-nth hashcode* sequence-hashcode-step swapd array-nth hashcode* sequence-hashcode-step
] 2curry each ] 2curry each

4
core/combinators/combinators.factor
View File

@ -123,7 +123,7 @@ ERROR: no-case object ;
[ [ [ literalize ] dip ] 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
[ dispatch ] curry append ; [ dispatch ] curry append ;
: hash-case-quot ( default assoc -- quot ) : hash-case-quot ( default assoc -- quot )
@ -162,7 +162,7 @@ ERROR: no-case object ;
! recursive-hashcode ! recursive-hashcode
: recursive-hashcode ( n obj quot -- code ) : recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ [ 1- ] 2dip call ] if ; inline pick 0 <= [ 3drop 0 ] [ [ 1 - ] 2dip call ] if ; inline
! These go here, not in sequences and hashtables, since those ! These go here, not in sequences and hashtables, since those
! two cannot depend on us ! two cannot depend on us

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

@ -4,7 +4,7 @@ kernel.private accessors eval ;
IN: continuations.tests IN: continuations.tests
: (callcc1-test) ( n obj -- n' obj ) : (callcc1-test) ( n obj -- n' obj )
[ 1- dup ] dip ?push [ 1 - dup ] dip ?push
over 0 = [ "test-cc" get continue-with ] when over 0 = [ "test-cc" get continue-with ] when
(callcc1-test) ; (callcc1-test) ;

2
core/generic/single/single.factor
View File

@ -178,7 +178,7 @@ M: echelon-dispatch-engine compile-engine
M: tuple-dispatch-engine compile-engine M: tuple-dispatch-engine compile-engine
tuple assumed [ tuple assumed [
echelons>> compile-engines echelons>> compile-engines
dup keys supremum 1+ f <array> dup keys supremum 1 + f <array>
[ <enum> swap update ] keep [ <enum> swap update ] keep
] with-variable ; ] with-variable ;

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

@ -28,7 +28,7 @@ CONSTANT: simple-combination T{ standard-combination f 0 }
{ 0 [ [ dup ] ] } { 0 [ [ dup ] ] }
{ 1 [ [ over ] ] } { 1 [ [ over ] ] }
{ 2 [ [ pick ] ] } { 2 [ [ pick ] ] }
[ 1- (picker) [ dip swap ] curry ] [ 1 - (picker) [ dip swap ] curry ]
} case ; } case ;
M: standard-combination picker M: standard-combination picker

2
core/growable/growable.factor
View File

@ -35,7 +35,7 @@ M: growable set-length ( n seq -- )
] if ] if
(>>length) ; (>>length) ;
: new-size ( old -- new ) 1+ 3 * ; inline : new-size ( old -- new ) 1 + 3 * ; inline
: ensure ( n seq -- n seq ) : ensure ( n seq -- n seq )
growable-check growable-check

10
core/hashtables/hashtables.factor
View File

@ -34,7 +34,7 @@ TUPLE: hashtable
[ no-key ] [ 2dup hash@ (key@) ] if ; inline [ no-key ] [ 2dup hash@ (key@) ] if ; inline
: <hash-array> ( n -- array ) : <hash-array> ( n -- array )
1+ next-power-of-2 4 * ((empty)) <array> ; inline 1 + next-power-of-2 4 * ((empty)) <array> ; inline
: init-hash ( hash -- ) : init-hash ( hash -- )
0 >>count 0 >>deleted drop ; inline 0 >>count 0 >>deleted drop ; inline
@ -61,10 +61,10 @@ TUPLE: hashtable
1 fixnum+fast set-slot ; inline 1 fixnum+fast set-slot ; inline
: hash-count+ ( hash -- ) : hash-count+ ( hash -- )
[ 1+ ] change-count drop ; inline [ 1 + ] change-count drop ; inline
: hash-deleted+ ( hash -- ) : hash-deleted+ ( hash -- )
[ 1+ ] change-deleted drop ; inline [ 1 + ] change-deleted drop ; inline
: (rehash) ( hash alist -- ) : (rehash) ( hash alist -- )
swap [ swapd set-at ] curry assoc-each ; inline swap [ swapd set-at ] curry assoc-each ; inline
@ -77,7 +77,7 @@ TUPLE: hashtable
[ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline
: grow-hash ( hash -- ) : grow-hash ( hash -- )
[ [ >alist ] [ assoc-size 1+ ] bi ] keep [ [ >alist ] [ assoc-size 1 + ] bi ] keep
[ reset-hash ] keep [ reset-hash ] keep
swap (rehash) ; swap (rehash) ;
@ -139,7 +139,7 @@ M: hashtable set-at ( value key hash -- )
PRIVATE> PRIVATE>
M: hashtable >alist M: hashtable >alist
[ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [ [ array>> [ length 2/ iota ] keep ] [ assoc-size <vector> ] bi [
[ [
[ [
[ 1 fixnum-shift-fast ] dip [ 1 fixnum-shift-fast ] dip

6
core/io/pathnames/pathnames.factor
View File

@ -17,7 +17,7 @@ SYMBOL: current-directory
[ path-separator? ] trim-head ; [ path-separator? ] trim-head ;
: last-path-separator ( path -- n ? ) : last-path-separator ( path -- n ? )
[ length 1- ] keep [ path-separator? ] find-last-from ; [ length 1 - ] keep [ path-separator? ] find-last-from ;
HOOK: root-directory? io-backend ( path -- ? ) HOOK: root-directory? io-backend ( path -- ? )
@ -30,7 +30,7 @@ ERROR: no-parent-directory path ;
dup root-directory? [ dup root-directory? [
trim-tail-separators trim-tail-separators
dup last-path-separator [ dup last-path-separator [
1+ cut 1 + cut
] [ ] [
drop "." swap drop "." swap
] if ] if
@ -113,7 +113,7 @@ PRIVATE>
: file-name ( path -- string ) : file-name ( path -- string )
dup root-directory? [ dup root-directory? [
trim-tail-separators trim-tail-separators
dup last-path-separator [ 1+ tail ] [ dup last-path-separator [ 1 + tail ] [
drop special-path? [ file-name ] when drop special-path? [ file-name ] when
] if ] if
] unless ; ] unless ;

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

@ -12,7 +12,7 @@ SLOT: i
[ i>> ] [ underlying>> ] bi ; inline [ i>> ] [ underlying>> ] bi ; inline
: next ( stream -- ) : next ( stream -- )
[ 1+ ] change-i drop ; inline [ 1 + ] change-i drop ; inline
: sequence-read1 ( stream -- elt/f ) : sequence-read1 ( stream -- elt/f )
[ >sequence-stream< ?nth ] [ next ] bi ; inline [ >sequence-stream< ?nth ] [ next ] bi ; inline

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

@ -114,7 +114,7 @@ IN: kernel.tests
! Regression ! Regression
: (loop) ( a b c d -- ) : (loop) ( a b c d -- )
[ pick ] dip swap [ pick ] dip swap [ pick ] dip swap [ pick ] dip swap
< [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive < [ [ 1 + ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
: loop ( obj -- ) : loop ( obj -- )
H{ } values swap [ dup length swap ] dip 0 -roll (loop) ; H{ } values swap [ dup length swap ] dip 0 -roll (loop) ;

6
core/layouts/layouts.factor
View File

@ -49,13 +49,13 @@ SYMBOL: mega-cache-size
cell-bits (first-bignum) ; inline cell-bits (first-bignum) ; inline
: most-positive-fixnum ( -- n ) : most-positive-fixnum ( -- n )
first-bignum 1- ; inline first-bignum 1 - ; inline
: most-negative-fixnum ( -- n ) : most-negative-fixnum ( -- n )
first-bignum neg ; inline first-bignum neg ; inline
: (max-array-capacity) ( b -- n ) : (max-array-capacity) ( b -- n )
5 - 2^ 1- ; inline 5 - 2^ 1 - ; inline
: max-array-capacity ( -- n ) : max-array-capacity ( -- n )
cell-bits (max-array-capacity) ; inline cell-bits (max-array-capacity) ; inline
@ -64,7 +64,7 @@ SYMBOL: mega-cache-size
bootstrap-cell-bits (first-bignum) ; bootstrap-cell-bits (first-bignum) ;
: bootstrap-most-positive-fixnum ( -- n ) : bootstrap-most-positive-fixnum ( -- n )
bootstrap-first-bignum 1- ; bootstrap-first-bignum 1 - ;
: bootstrap-most-negative-fixnum ( -- n ) : bootstrap-most-negative-fixnum ( -- n )
bootstrap-first-bignum neg ; bootstrap-first-bignum neg ;

4
core/lexer/lexer.factor
View File

@ -9,7 +9,7 @@ TUPLE: lexer text line line-text line-length column ;
: next-line ( lexer -- ) : next-line ( lexer -- )
dup [ line>> ] [ text>> ] bi ?nth >>line-text dup [ line>> ] [ text>> ] bi ?nth >>line-text
dup line-text>> length >>line-length dup line-text>> length >>line-length
[ 1+ ] change-line [ 1 + ] change-line
0 >>column 0 >>column
drop ; drop ;
@ -39,7 +39,7 @@ GENERIC: skip-word ( lexer -- )
M: lexer skip-word ( lexer -- ) M: lexer skip-word ( lexer -- )
[ [
2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if 2dup nth CHAR: " eq? [ drop 1 + ] [ f skip ] if
] change-lexer-column ; ] change-lexer-column ;
: still-parsing? ( lexer -- ? ) : still-parsing? ( lexer -- ? )

4
core/math/floats/floats-tests.factor
View File

@ -50,8 +50,8 @@ IN: math.floats.tests
[ BIN: 11111111111000000000000000000000000000000000000000000000000000 bits>double ] [ BIN: 11111111111000000000000000000000000000000000000000000000000000 bits>double ]
unit-test unit-test
[ 2.0 ] [ 1.0 1+ ] unit-test [ 2.0 ] [ 1.0 1 + ] unit-test
[ 0.0 ] [ 1.0 1- ] unit-test [ 0.0 ] [ 1.0 1 - ] unit-test
[ t ] [ 0.0 zero? ] unit-test [ t ] [ 0.0 zero? ] unit-test
[ t ] [ -0.0 zero? ] unit-test [ t ] [ -0.0 zero? ] unit-test

4
core/math/integers/integers-tests.factor
View File

@ -206,8 +206,8 @@ unit-test
[ 2. ] [ 2 1 ratio>float ] unit-test [ 2. ] [ 2 1 ratio>float ] unit-test
[ .5 ] [ 1 2 ratio>float ] unit-test [ .5 ] [ 1 2 ratio>float ] unit-test
[ .75 ] [ 3 4 ratio>float ] unit-test [ .75 ] [ 3 4 ratio>float ] unit-test
[ 1. ] [ 2000 2^ 2000 2^ 1+ ratio>float ] unit-test [ 1. ] [ 2000 2^ 2000 2^ 1 + ratio>float ] unit-test
[ -1. ] [ 2000 2^ neg 2000 2^ 1+ ratio>float ] unit-test [ -1. ] [ 2000 2^ neg 2000 2^ 1 + ratio>float ] unit-test
[ 0.4 ] [ 6 15 ratio>float ] unit-test [ 0.4 ] [ 6 15 ratio>float ] unit-test
[ HEX: 3fe553522d230931 ] [ HEX: 3fe553522d230931 ]

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

@ -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 ( x -- n ) : fixnum-log2 ( x -- n )
0 swap [ dup 1 eq? ] [ [ 1+ ] [ 2/ ] bi* ] until drop ; 0 swap [ dup 1 eq? ] [ [ 1 + ] [ 2/ ] bi* ] until drop ;
M: fixnum (log2) fixnum-log2 ; M: fixnum (log2) fixnum-log2 ;
@ -86,7 +86,7 @@ M: bignum (log2) bignum-log2 ;
! provided with absolutely no warranty." ! provided with absolutely no warranty."
! First step: pre-scaling ! First step: pre-scaling
: twos ( x -- y ) dup 1- bitxor log2 ; inline : twos ( x -- y ) dup 1 - bitxor log2 ; inline
: scale-denonimator ( den -- scaled-den scale' ) : scale-denonimator ( den -- scaled-den scale' )
dup twos neg [ shift ] keep ; inline dup twos neg [ shift ] keep ; inline
@ -98,7 +98,7 @@ M: bignum (log2) bignum-log2 ;
! Second step: loop ! Second step: loop
: shift-mantissa ( scale mantissa -- scale' mantissa' ) : shift-mantissa ( scale mantissa -- scale' mantissa' )
[ 1+ ] [ 2/ ] bi* ; inline [ 1 + ] [ 2/ ] bi* ; inline
: /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 > ]
@ -107,7 +107,7 @@ M: bignum (log2) bignum-log2 ;
! Third step: post-scaling ! Third step: post-scaling
: unscaled-float ( mantissa -- n ) : unscaled-float ( mantissa -- n )
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' )
[ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline [ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline
@ -126,7 +126,7 @@ M: bignum (log2) bignum-log2 ;
] [ ] [
pre-scale pre-scale
/f-loop over odd? /f-loop over odd?
[ zero? [ 1+ ] unless ] [ drop ] if [ zero? [ 1 + ] unless ] [ drop ] if
post-scale post-scale
] if ] if
] if ; inline ] if ; inline

12
core/math/math.factor
View File

@ -63,7 +63,7 @@ PRIVATE>
: neg ( x -- -x ) 0 swap - ; inline : neg ( x -- -x ) 0 swap - ; inline
: recip ( x -- y ) 1 swap / ; inline : recip ( x -- y ) 1 swap / ; inline
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline : sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
: ?1+ ( x -- y ) [ 1+ ] [ 0 ] if* ; inline : ?1+ ( x -- y ) [ 1 + ] [ 0 ] if* ; inline
: rem ( x y -- z ) abs [ mod ] [ + ] [ mod ] tri ; foldable : rem ( x y -- z ) abs [ mod ] [ + ] [ mod ] tri ; foldable
: 2^ ( n -- 2^n ) 1 swap shift ; inline : 2^ ( n -- 2^n ) 1 swap shift ; inline
: even? ( n -- ? ) 1 bitand zero? ; : even? ( n -- ? ) 1 bitand zero? ;
@ -103,13 +103,13 @@ M: float fp-infinity? ( float -- ? )
] if ; ] if ;
: next-power-of-2 ( m -- n ) : next-power-of-2 ( m -- n )
dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; inline dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline
: power-of-2? ( n -- ? ) : power-of-2? ( n -- ? )
dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable dup 0 <= [ drop f ] [ dup 1 - bitand zero? ] if ; foldable
: align ( m w -- n ) : align ( m w -- n )
1- [ + ] keep bitnot bitand ; inline 1 - [ + ] keep bitnot bitand ; inline
<PRIVATE <PRIVATE
@ -121,7 +121,7 @@ M: float fp-infinity? ( float -- ? )
#! Apply quot to i, keep i and quot, hide n. #! Apply quot to i, keep i and quot, hide n.
[ nip call ] 3keep ; inline [ nip call ] 3keep ; inline
: iterate-next ( i n quot -- i' n quot ) [ 1+ ] 2dip ; inline : iterate-next ( i n quot -- i' n quot ) [ 1 + ] 2dip ; inline
PRIVATE> PRIVATE>
@ -160,6 +160,6 @@ PRIVATE>
[ call ] 2keep rot [ [ call ] 2keep rot [
drop drop
] [ ] [
[ 1- ] dip find-last-integer [ 1 - ] dip find-last-integer
] if ] if
] if ; inline recursive ] if ; inline recursive

2
core/namespaces/namespaces.factor
View File

@ -29,7 +29,7 @@ PRIVATE>
: inc ( variable -- ) 1 swap +@ ; inline : inc ( variable -- ) 1 swap +@ ; inline
: dec ( variable -- ) -1 swap +@ ; inline : dec ( variable -- ) -1 swap +@ ; inline
: bind ( ns quot -- ) swap >n call ndrop ; inline : bind ( ns quot -- ) swap >n call ndrop ; inline
: counter ( variable -- n ) [ 0 or 1+ dup ] change-global ; : counter ( variable -- n ) [ 0 or 1 + dup ] change-global ;
: make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline : make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
: with-scope ( quot -- ) 5 <hashtable> swap bind ; inline : with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
: with-variable ( value key quot -- ) [ associate ] dip bind ; inline : with-variable ( value key quot -- ) [ associate ] dip bind ; inline

4
core/quotations/quotations.factor
View File

@ -48,12 +48,12 @@ M: object literalize ;
M: wrapper literalize <wrapper> ; M: wrapper literalize <wrapper> ;
M: curry length quot>> length 1+ ; M: curry length quot>> length 1 + ;
M: curry nth M: curry nth
over 0 = over 0 =
[ nip obj>> literalize ] [ nip obj>> literalize ]
[ [ 1- ] dip quot>> nth ] [ [ 1 - ] dip quot>> nth ]
if ; if ;
INSTANCE: curry immutable-sequence INSTANCE: curry immutable-sequence

36
core/sequences/sequences.factor
View File

@ -198,7 +198,7 @@ C: <reversed> reversed
M: reversed virtual-seq seq>> ; M: reversed virtual-seq seq>> ;
M: reversed virtual@ seq>> [ length swap - 1- ] keep ; M: reversed virtual@ seq>> [ length swap - 1 - ] keep ;
M: reversed length seq>> length ; M: reversed length seq>> length ;
@ -276,7 +276,7 @@ INSTANCE: repetition immutable-sequence
] 3keep ; inline ] 3keep ; inline
: (copy) ( dst i src j n -- dst ) : (copy) ( dst i src j n -- dst )
dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ; dup 0 <= [ 2drop 2drop ] [ 1 - ((copy)) (copy) ] if ;
inline recursive inline recursive
: prepare-subseq ( from to seq -- dst i src j n ) : prepare-subseq ( from to seq -- dst i src j n )
@ -460,7 +460,7 @@ 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 )
[ [ 1- ] dip 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
@ -556,7 +556,7 @@ PRIVATE>
[ empty? not ] filter ; [ empty? not ] filter ;
: mismatch ( seq1 seq2 -- i ) : mismatch ( seq1 seq2 -- i )
[ min-length ] 2keep [ min-length iota ] 2keep
[ 2nth-unsafe = not ] 2curry [ 2nth-unsafe = not ] 2curry
find drop ; inline find drop ; inline
@ -595,8 +595,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: (filter-here) ( quot: ( elt -- ? ) store scan seq -- ) : (filter-here) ( quot: ( elt -- ? ) store scan seq -- )
2dup length < [ 2dup length < [
[ move ] 3keep [ move ] 3keep
[ nth-unsafe pick call [ 1+ ] when ] 2keep [ nth-unsafe pick call [ 1 + ] when ] 2keep
[ 1+ ] dip [ 1 + ] dip
(filter-here) (filter-here)
] [ nip set-length drop ] if ; inline recursive ] [ nip set-length drop ] if ; inline recursive
@ -612,20 +612,20 @@ PRIVATE>
[ eq? not ] with filter-here ; [ eq? not ] with filter-here ;
: prefix ( seq elt -- newseq ) : prefix ( seq elt -- newseq )
over [ over length 1+ ] dip [ 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 [ over length 1+ ] dip [ over [ over length 1 + ] dip [
[ [ over length ] dip set-nth-unsafe ] keep [ [ over length ] dip set-nth-unsafe ] keep
[ 0 swap copy ] keep [ 0 swap copy ] keep
] new-like ; ] new-like ;
: peek ( seq -- elt ) [ length 1- ] [ nth ] bi ; : peek ( seq -- elt ) [ length 1 - ] [ nth ] bi ;
: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ; : pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ;
<PRIVATE <PRIVATE
@ -633,7 +633,7 @@ PRIVATE>
2over = [ 2over = [
2drop 2drop 2drop 2drop
] [ ] [
[ [ 2over + pick ] dip move [ 1+ ] dip ] keep [ [ 2over + pick ] dip move [ 1 + ] dip ] keep
move-backward move-backward
] if ; ] if ;
@ -641,13 +641,13 @@ PRIVATE>
2over = [ 2over = [
2drop 2drop 2drop 2drop
] [ ] [
[ [ pick [ dup dup ] dip + swap ] dip 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 ? -- )
[ [
[ [ 1- ] bi@ ] dip move-forward [ [ 1 - ] bi@ ] dip move-forward
] [ ] [
[ over - ] 2dip move-backward [ over - ] 2dip move-backward
] if ; ] if ;
@ -667,7 +667,7 @@ PRIVATE>
check-slice [ over [ - ] dip ] dip open-slice ; check-slice [ over [ - ] dip ] dip open-slice ;
: delete-nth ( n seq -- ) : delete-nth ( n seq -- )
[ dup 1+ ] dip delete-slice ; [ dup 1 + ] dip delete-slice ;
: snip ( from to seq -- head tail ) : snip ( from to seq -- head tail )
[ swap head ] [ swap tail ] bi-curry bi* ; inline [ swap head ] [ swap tail ] bi-curry bi* ; inline
@ -679,10 +679,10 @@ PRIVATE>
snip-slice surround ; snip-slice surround ;
: remove-nth ( n seq -- seq' ) : remove-nth ( n seq -- seq' )
[ [ { } ] dip dup 1+ ] dip replace-slice ; [ [ { } ] dip dup 1 + ] dip replace-slice ;
: pop ( seq -- elt ) : pop ( seq -- elt )
[ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ; [ length 1 - ] [ [ nth ] [ shorten ] 2bi ] bi ;
: exchange ( m n seq -- ) : exchange ( m n seq -- )
[ nip bounds-check 2drop ] [ nip bounds-check 2drop ]
@ -692,7 +692,7 @@ PRIVATE>
: reverse-here ( seq -- ) : reverse-here ( seq -- )
[ length 2/ ] [ length ] [ ] tri [ length 2/ ] [ length ] [ ] tri
[ [ over - 1- ] dip exchange-unsafe ] 2curry each ; [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ;
: reverse ( seq -- newseq ) : reverse ( seq -- newseq )
[ [
@ -799,7 +799,7 @@ PRIVATE>
PRIVATE> 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 [ 3drop ] dip ; swap [ 3drop ] dip ;

12
core/sorting/sorting.factor
View File

@ -29,13 +29,13 @@ TUPLE: merge
[ [ [ 2drop ] dip nth-unsafe ] dip push ] [ [ [ [ 2drop ] dip nth-unsafe ] dip push ] [
pick 2 = [ pick 2 = [
[ [
[ 2drop dup 1+ ] dip [ 2drop dup 1 + ] dip
[ nth-unsafe ] curry bi@ [ nth-unsafe ] curry bi@
] dip [ push ] curry bi@ ] dip [ push ] curry bi@
] [ ] [
pick 3 = [ pick 3 = [
[ [
[ 2drop dup 1+ dup 1+ ] dip [ 2drop dup 1 + dup 1 + ] dip
[ nth-unsafe ] curry tri@ [ nth-unsafe ] curry tri@
] dip [ push ] curry tri@ ] dip [ push ] curry tri@
] [ [ nip subseq ] dip push-all ] if ] [ [ nip subseq ] dip push-all ] if
@ -57,10 +57,10 @@ TUPLE: merge
[ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
: l-next ( merge -- ) : l-next ( merge -- )
[ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline [ [ l-elt ] [ [ 1 + ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
: r-next ( merge -- ) : r-next ( merge -- )
[ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline [ [ r-elt ] [ [ 1 + ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
: decide ( merge -- ? ) : decide ( merge -- ? )
[ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
@ -129,8 +129,8 @@ TUPLE: merge
while 2drop ; inline while 2drop ; inline
: each-pair ( seq quot -- ) : each-pair ( seq quot -- )
[ [ length 1+ 2/ ] keep ] dip [ [ length 1 + 2/ ] keep ] dip
[ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline [ [ 1 shift dup 1 + ] dip ] prepose curry each-integer ; inline
: (sort-pairs) ( i1 i2 seq quot accum -- ) : (sort-pairs) ( i1 i2 seq quot accum -- )
[ 2dup length = ] 2dip rot [ [ 2dup length = ] 2dip rot [

2
core/splitting/splitting.factor
View File

@ -55,7 +55,7 @@ PRIVATE>
: (split) ( separators n seq -- ) : (split) ( separators n seq -- )
3dup rot [ member? ] curry find-from drop 3dup rot [ member? ] curry find-from drop
[ [ swap subseq , ] 2keep 1+ swap (split) ] [ [ swap subseq , ] 2keep 1 + swap (split) ]
[ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive
: split, ( seq separators -- ) 0 rot (split) ; : split, ( seq separators -- ) 0 rot (split) ;

4
core/syntax/syntax-docs.factor
View File

@ -749,7 +749,7 @@ HELP: <PRIVATE
"<PRIVATE" "<PRIVATE"
"" ""
": (fac) ( accum n -- n! )" ": (fac) ( accum n -- n! )"
" dup 1 <= [ drop ] [ [ * ] keep 1- (fac) ] if ;" " dup 1 <= [ drop ] [ [ * ] keep 1 - (fac) ] if ;"
"" ""
"PRIVATE>" "PRIVATE>"
"" ""
@ -760,7 +760,7 @@ HELP: <PRIVATE
"IN: factorial.private" "IN: factorial.private"
"" ""
": (fac) ( accum n -- n! )" ": (fac) ( accum n -- n! )"
" dup 1 <= [ drop ] [ [ * ] keep 1- (fac) ] if ;" " dup 1 <= [ drop ] [ [ * ] keep 1 - (fac) ] if ;"
"" ""
"IN: factorial" "IN: factorial"
"" ""