From: Doug Coleman Date: Sat, 6 Aug 2022 22:55:18 +0000 (-0500) Subject: core: push-if -> push-when, refactoring sequence words X-Git-Tag: 0.99~620 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=170fcd10f207f7f8aedbf1e286bd7b3f29fdcd3a core: push-if -> push-when, refactoring sequence words --- diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index 5ec3d0a5f3..fb0c460985 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -82,7 +82,7 @@ PRIVATE> : read-ignoring ( n ignoring stream -- accum ) pick [ - '[ _ _ read1-ignoring [ ] _ push-if ] times + '[ _ _ read1-ignoring [ ] _ push-when ] times ] keep ; : decode4 ( a b c d -- x y z ) diff --git a/basis/bit-sets/bit-sets.factor b/basis/bit-sets/bit-sets.factor index 341f81b10b..5e3d39d8c7 100644 --- a/basis/bit-sets/bit-sets.factor +++ b/basis/bit-sets/bit-sets.factor @@ -35,7 +35,7 @@ ERROR: check-bit-set-failed ; dup bit-set? [ check-bit-set-failed ] unless ; inline : bit-set-map ( seq1 seq2 quot -- seq ) - [ drop [ length ] bi@ [ assert= ] keep ] + [ drop 2length [ assert= ] keep ] [ [ [ underlying>> ] bi@ ] dip 2map ] 3bi bit-array boa ; inline diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index 20273006c8..8b597a58b4 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -14,7 +14,7 @@ GENERIC: infer-known* ( known -- effect ) ] [ infer-known* ] if ; IDENTITY-MEMO: inputs/outputs ( quot -- in out ) - infer [ in>> ] [ out>> ] bi [ length ] bi@ ; + infer [ in>> ] [ out>> ] bi 2length ; : inputs ( quot -- n ) inputs/outputs drop ; inline diff --git a/basis/io/crlf/crlf.factor b/basis/io/crlf/crlf.factor index 013cbbc19f..e173a80173 100644 --- a/basis/io/crlf/crlf.factor +++ b/basis/io/crlf/crlf.factor @@ -38,7 +38,7 @@ IN: io.crlf input-stream get stream-read1-ignoring-crlf ; : push-ignoring-crlf ( elt seq -- ) - [ "\r\n" member? not ] swap push-if ; + [ "\r\n" member? not ] swap push-when ; : push-all-ignoring-crlf ( src dst -- ) [ push-ignoring-crlf ] curry each ; diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor index ade3cf9434..dcad9fb99b 100644 --- a/basis/math/primes/primes.factor +++ b/basis/math/primes/primes.factor @@ -57,7 +57,7 @@ PRIVATE> : (primes-between) ( low high -- seq ) [ ] [ ] 2bi - [ '[ [ prime? ] _ push-if ] each ] keep ; + [ '[ [ prime? ] _ push-when ] each ] keep ; PRIVATE> diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 97955390a1..a795169325 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -11,6 +11,8 @@ TUPLE: effect { in-var read-only } { out-var read-only } ; +: in-out ( effect -- in out ) [ in>> ] [ out>> ] bi ; inline + : ?terminated ( out -- out terminated? ) dup { "*" } = [ drop { } t ] [ f ] if ; diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 8cebd36ec3..ce5291fe9c 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -568,7 +568,7 @@ HELP: all? { $values { "seq" sequence } { "quot" { $quotation ( ... elt -- ... ? ) } } { "?" boolean } } { $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." } ; -HELP: push-if +HELP: push-when { $values { "elt" object } { "quot" { $quotation ( ..a elt -- ..b ? ) } } { "accum" "a resizable mutable sequence" } } { $description "Adds the element at the end of the sequence if the quotation yields a true value." } { $notes "This word is a factor of " { $link filter } "." } ; @@ -696,7 +696,7 @@ HELP: replace-slice { $description "Replaces a range of elements beginning at index " { $snippet "from" } " and ending before index " { $snippet "to" } " with a new sequence." } { $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." } ; -{ push push-either push-if pop pop* prefix suffix suffix! } related-words +{ push push-either push-when pop pop* prefix suffix suffix! } related-words HELP: suffix { $values { "seq" sequence } { "elt" object } { "newseq" sequence } } diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index d7d7904745..9610d4cd33 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -15,6 +15,12 @@ GENERIC: new-resizable ( len seq -- newseq ) flushable GENERIC: like ( seq exemplar -- newseq ) flushable GENERIC: clone-like ( seq exemplar -- newseq ) flushable +: new-sequence-like ( len-exemplar type-exemplar -- newseq ) + [ length ] dip new-sequence ; inline + +: new-resizable-like ( len-exemplar type-exemplar -- newseq ) + [ length ] dip new-resizable ; inline + : new-like ( len exemplar quot -- seq ) over [ [ new-sequence ] dip call ] dip like ; inline @@ -26,6 +32,9 @@ GENERIC: shorten ( n seq -- ) M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; inline M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; inline +: 2length ( seq1 seq2 -- n1 n2 ) [ length ] bi@ ; inline +: 3length ( seq1 seq2 seq3 -- n1 n2 n3 ) [ length ] tri@ ; inline + : empty? ( seq -- ? ) length 0 = ; inline : if-empty ( ..a seq quot1: ( ..a -- ..b ) quot2: ( ..a seq -- ..b ) -- ..b ) @@ -355,7 +364,7 @@ PRIVATE> : copy ( src i dst -- ) check-copy copy-unsafe ; inline M: sequence clone-like - [ dup length ] dip new-sequence [ 0 swap copy-unsafe ] keep ; inline + dupd new-sequence-like [ 0 swap copy-unsafe ] keep ; inline M: immutable-sequence clone-like like ; inline @@ -371,7 +380,7 @@ M: immutable-sequence clone-like like ; inline PRIVATE> : append-as ( seq1 seq2 exemplar -- newseq ) - [ 2dup [ length ] bi@ + ] dip + [ 2dup 2length + ] dip [ (append) ] new-like ; inline : append ( seq1 seq2 -- newseq ) over append-as ; @@ -381,8 +390,8 @@ PRIVATE> : prepend ( seq1 seq2 -- newseq ) over prepend-as ; : 3append-as ( seq1 seq2 seq3 exemplar -- newseq ) - [ 3dup [ length ] tri@ + + ] dip [ - [ [ 2over [ length ] bi@ + ] dip copy-unsafe ] + [ 3dup 3length + + ] dip [ + [ [ 2over 2length + ] dip copy-unsafe ] [ (append) ] bi ] new-like ; inline @@ -587,13 +596,19 @@ PRIVATE> : all? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) sequence-operator all-integers-from? ; inline -: push-if ( ..a elt quot: ( ..a elt -- ..b ? ) accum -- ..b ) +: push-when ( ..a elt quot: ( ..a elt -- ..b ? ) accum -- ..b ) [ keep ] dip rot [ push ] [ 2drop ] if ; inline +: keep-push-when ( ..a elt quot: ( ..a elt -- ..b ? ) accum -- ..b ) + [ keep ] dip rot [ push ] [ 2drop ] if ; inline + +: call-push-when ( ..a elt quot: ( ..a elt -- ..b elt' ? ) accum -- ..b ) + [ call ] dip swap [ push ] [ 2drop ] if ; inline + @@ -625,10 +640,10 @@ PRIVATE> over [ 2selector [ each ] 2dip ] dip [ like ] curry bi@ ; inline : collector-for-as ( seq quot exemplar -- seq quot' vec ) - [ over length ] dip new-resizable [ [ push ] curry compose ] keep ; inline + overd new-resizable-like [ [ push ] curry compose ] keep ; inline : collector-as ( quot exemplar -- quot' vec ) - [ length ] keep new-resizable [ [ push ] curry compose ] keep ; inline + dup new-resizable-like [ [ push ] curry compose ] keep ; inline : collector-for ( seq quot -- seq quot' vec ) V{ } collector-for-as ; inline diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor index 770a3aafff..d447e30374 100644 --- a/extra/sequences/extras/extras.factor +++ b/extra/sequences/extras/extras.factor @@ -725,7 +725,7 @@ PRIVATE> : extract! ( ... seq quot: ( ... elt -- ... ? ) -- ... seq ) [ dup ] compose over [ length ] keep new-resizable - [ [ push-if ] 2curry reject! ] keep swap like ; inline + [ [ push-when ] 2curry reject! ] keep swap like ; inline : find-pred-loop ( ... i n seq quot: ( ... elt -- ... calc ? ) -- ... calc/f i/f elt/f ) 2pick < [