clean up some stack shuffling
parent
802283c94c
commit
ae75b41a43
|
@ -12,31 +12,32 @@ GENERIC: cursor-write ( obj cursor -- )
|
|||
ERROR: cursor-ended cursor ;
|
||||
|
||||
: cursor-get ( cursor -- obj )
|
||||
dup cursor-done?
|
||||
[ cursor-ended ] [ cursor-get-unsafe ] if ; inline
|
||||
dup cursor-done?
|
||||
[ cursor-ended ] [ cursor-get-unsafe ] if ; inline
|
||||
|
||||
: find-done? ( quot cursor -- ? )
|
||||
dup cursor-done? [ 2drop t ] [ cursor-get-unsafe swap call ] if ; inline
|
||||
|
||||
: cursor-until ( quot cursor -- )
|
||||
[ find-done? not ]
|
||||
[ cursor-advance drop ] bi-curry bi-curry while ; inline
|
||||
: find-done? ( cursor quot -- ? )
|
||||
over cursor-done?
|
||||
[ 2drop t ] [ [ cursor-get-unsafe ] dip call ] if ; inline
|
||||
|
||||
: cursor-until ( cursor quot -- )
|
||||
[ find-done? not ]
|
||||
[ drop cursor-advance ] bi-curry bi-curry while ; inline
|
||||
|
||||
: cursor-each ( cursor quot -- )
|
||||
[ f ] compose swap cursor-until ; inline
|
||||
[ f ] compose cursor-until ; inline
|
||||
|
||||
: cursor-find ( cursor quot -- obj ? )
|
||||
swap [ cursor-until ] keep
|
||||
dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
|
||||
[ cursor-until ] [ drop ] 2bi
|
||||
dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
|
||||
|
||||
: cursor-any? ( cursor quot -- ? )
|
||||
cursor-find nip ; inline
|
||||
cursor-find nip ; inline
|
||||
|
||||
: cursor-all? ( cursor quot -- ? )
|
||||
[ not ] compose cursor-any? not ; inline
|
||||
[ not ] compose cursor-any? not ; inline
|
||||
|
||||
: cursor-map-quot ( quot to -- quot' )
|
||||
[ [ call ] dip cursor-write ] 2curry ; inline
|
||||
[ [ call ] dip cursor-write ] 2curry ; inline
|
||||
|
||||
: cursor-map ( from to quot -- )
|
||||
swap cursor-map-quot cursor-each ; inline
|
||||
|
@ -46,10 +47,10 @@ ERROR: cursor-ended cursor ;
|
|||
[ cursor-write ] 2curry when ; inline
|
||||
|
||||
: cursor-filter-quot ( quot to -- quot' )
|
||||
[ cursor-write-if ] 2curry ; inline
|
||||
[ cursor-write-if ] 2curry ; inline
|
||||
|
||||
: cursor-filter ( from to quot -- )
|
||||
swap cursor-filter-quot cursor-each ; inline
|
||||
swap cursor-filter-quot cursor-each ; inline
|
||||
|
||||
TUPLE: from-sequence { seq sequence } { n integer } ;
|
||||
|
||||
|
@ -60,19 +61,19 @@ M: from-sequence cursor-done? ( cursor -- ? )
|
|||
>from-sequence< length >= ;
|
||||
|
||||
M: from-sequence cursor-valid?
|
||||
>from-sequence< bounds-check? not ;
|
||||
>from-sequence< bounds-check? not ;
|
||||
|
||||
M: from-sequence cursor-get-unsafe
|
||||
>from-sequence< nth-unsafe ;
|
||||
>from-sequence< nth-unsafe ;
|
||||
|
||||
M: from-sequence cursor-advance
|
||||
[ 1+ ] change-n drop ;
|
||||
[ 1+ ] change-n drop ;
|
||||
|
||||
: >input ( seq -- cursor )
|
||||
0 from-sequence boa ; inline
|
||||
0 from-sequence boa ; inline
|
||||
|
||||
: iterate ( seq quot iterator -- )
|
||||
[ >input ] 2dip call ; inline
|
||||
[ >input ] 2dip call ; inline
|
||||
|
||||
: each ( seq quot -- ) [ cursor-each ] iterate ; inline
|
||||
: find ( seq quot -- ? ) [ cursor-find ] iterate ; inline
|
||||
|
@ -82,18 +83,19 @@ M: from-sequence cursor-advance
|
|||
TUPLE: to-sequence { seq sequence } { exemplar sequence } ;
|
||||
|
||||
M: to-sequence cursor-write
|
||||
seq>> push ;
|
||||
seq>> push ;
|
||||
|
||||
: freeze ( cursor -- seq )
|
||||
[ seq>> ] [ exemplar>> ] bi like ; inline
|
||||
[ seq>> ] [ exemplar>> ] bi like ; inline
|
||||
|
||||
: >output ( seq -- cursor )
|
||||
[ [ length ] keep new-resizable ] keep
|
||||
to-sequence boa ; inline
|
||||
[ [ length ] keep new-resizable ] keep
|
||||
to-sequence boa ; inline
|
||||
|
||||
: transform ( seq quot transformer -- newseq )
|
||||
[ [ >input ] [ >output ] bi ] 2dip
|
||||
[ call ] [ 2drop freeze ] 3bi ; inline
|
||||
[ [ >input ] [ >output ] bi ] 2dip
|
||||
[ call ]
|
||||
[ 2drop freeze ] 3bi ; inline
|
||||
|
||||
: map ( seq quot -- ) [ cursor-map ] transform ; inline
|
||||
: filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline
|
||||
|
|
Loading…
Reference in New Issue