#! pad string with = when not enough bits
dup length dup 3 mod - cut
[ 3 <groups> [ encode3 ] map concat ]
- [ dup empty? [ drop "" ] [ >base64-rem ] if ]
+ [ [ "" ] [ >base64-rem ] if-empty ]
bi* append ;
: base64> ( base64 -- str )
M: channel to ( value channel -- )
dup receivers>>
- dup empty? [ drop dup wait to ] [ nip (to) ] if ;
+ [ dup wait to ] [ nip (to) ] if-empty ;
M: channel from ( channel -- value )
[
notify senders>>
- dup empty? [ drop ] [ (from) ] if
+ [ (from) ] unless-empty
] curry "channel receive" suspend ;
: seq>2seq ( seq -- seq1 seq2 )
#! { abcdefgh } -> { aceg } { bdfh }
- 2 group flip dup empty? [ drop { } { } ] [ first2 ] if ;
+ 2 group flip [ { } { } ] [ first2 ] if-empty ;
: 2seq>seq ( seq1 seq2 -- seq )
#! { aceg } { bdfh } -> { abcdefgh }
[ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
: (tail-call?) ( cursor -- ? )
- dup empty? [ drop t ] [
+ [ t ] [
[ first [ #return? ] [ #terminate? ] bi or ]
[ tail-phi? ]
bi or
- ] if ;
+ ] if-empty ;
: tail-call? ( -- ? )
node-stack get [
rest-slice
- dup empty? [ drop t ] [
+ [ t ] [
[ (tail-call?) ]
[ first #terminate? not ]
bi and
- ] if
+ ] if-empty
] all? ;
M: #copy check-node* inputs/outputs 2array check-lengths ;
: check->r/r> ( node -- )
- inputs/outputs dup empty? [ 2drop ] [ 2array check-lengths ] if ;
+ inputs/outputs [ drop ] [ 2array check-lengths ] if-empty ;
M: #>r check-node* check->r/r> ;
[ cleanup* ] map flatten ;
: cleanup-folding? ( #call -- ? )
- node-output-infos dup empty?
- [ drop f ] [ [ literal?>> ] all? ] if ;
+ node-output-infos
+ [ f ] [ [ literal?>> ] all? ] if-empty ;
: cleanup-folding ( #call -- nodes )
#! Replace a #call having a known result with a #drop of its
: (merge-allocations) ( values -- allocation )
[
- dup [ allocation ] map sift dup empty? [ 2drop f ] [
+ dup [ allocation ] map sift [ drop f ] [
dup [ t eq? not ] all? [
dup [ length ] map all-equal? [
nip flip
[ record-allocations ] keep
] [ drop add-escaping-values t ] if
] [ drop add-escaping-values t ] if
- ] if
+ ] if-empty
] map ;
: merge-allocations ( in-values out-values -- )
dup [ collect-label-info ] each-node
dup count-introductions make-values
[ (normalize) ] [ nip ] 2bi
- dup empty? [ drop ] [ #introduce prefix ] if
+ [ #introduce prefix ] unless-empty
rename-node-values ;
} cond ;
: value-infos-union ( infos -- info )
- dup empty?
- [ drop null-info ]
- [ dup first [ value-info-union ] reduce ] if ;
+ [ null-info ]
+ [ dup first [ value-info-union ] reduce ] if-empty ;
: literals<= ( info1 info2 -- ? )
{
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
: ends-with-terminate? ( nodes -- ? )
- dup empty? [ drop f ] [ peek #terminate? ] if ;
+ [ f ] [ peek #terminate? ] if-empty ;
M: vector child-visitor V{ } clone ;
M: vector #introduce, #introduce node, ;
{ URL [ dup [ present ] when default-param-value ] }
[ drop default-param-value ]
} case 2array
- ] 2map flip dup empty? [
- drop f f
+ ] 2map flip [
+ f f
] [
first2 [ >c-void*-array ] [ >c-uint-array ] bi*
- ] if ;
+ ] if-empty ;
: param-formats ( statement -- seq )
in-params>> [ type>> type>param-format ] map >c-uint-array ;
: modifiers ( spec -- string )
modifiers>> [ lookup-modifier ] map " " join
- dup empty? [ " " prepend ] unless ;
+ [ "" ] [ " " prepend ] if-empty ;
HOOK: bind% db ( spec -- )
HOOK: bind# db ( spec obj -- )
] "" make print ;
: restarts. ( -- )
- restarts get dup empty? [
- drop
- ] [
+ restarts get [
nl
"The following restarts are available:" print
nl
[ restart. ] each-index
- ] if ;
+ ] unless-empty ;
: print-error ( error -- )
[ error. flush ] curry
code = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
=> [[ [ second >string ] [ fourth >string ] bi code boa ]]
-stand-alone = (code | heading | list | table | paragraph | nl)*
+simple-code
+ = "[{" (!("}]").)+ "}]"
+ => [[ second f swap code boa ]]
+
+stand-alone
+ = (code | simple-code | heading | list | table | paragraph | nl)*
;EBNF
] [
escape-link
>r "<img src=\"" write write "\"" write r>
- dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if
+ [ " alt=\"" write write "\"" write ] unless-empty
"/>" write
] if ;
: ((shallow-fry)) ( accum quot adder -- result )
>r shallow-fry r>
- append swap dup empty? [ drop ] [
+ append swap [
[ prepose ] curry append
- ] if ; inline
+ ] unless-empty ; inline
: (shallow-fry) ( accum quot -- result )
- dup empty? [
- drop 1quotation
+ [
+ 1quotation
] [
unclip {
{ \ , [ [ curry ] ((shallow-fry)) ] }
[ swap >r suffix r> (shallow-fry) ]
} case
- ] if ;
+ ] if-empty ;
: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
\r
: render-validation-messages ( -- )\r
form get errors>>\r
- dup empty? [ drop ] [\r
+ [\r
<ul "errors" =class ul>\r
[ <li> escape-string write </li> ] each\r
</ul>\r
- ] if ;\r
+ ] unless-empty ;\r
\r
CHLOE: validation-messages drop render-validation-messages ;\r
\r
2tri ;\r
\r
: set-nested-form ( form name -- )\r
- dup empty? [\r
- drop merge-forms\r
+ [\r
+ merge-forms\r
] [\r
unclip [ set-nested-form ] nest-form\r
- ] if ;\r
+ ] if-empty ;\r
\r
: restore-validation-errors ( -- )\r
form cget [\r
[
logged-in-user get
- "new-password" value dup empty?
- [ drop ] [ >>encoded-password ] if
+ "new-password" value
+ [ >>encoded-password ] unless-empty
"realname" value >>realname
"email" value >>email
! Chloe tags
: parse-query-attr ( string -- assoc )
- dup empty?
- [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
+ [ f ] [ "," split [ dup value ] H{ } map>assoc ] if-empty ;
: a-url-path ( tag -- string )
[ "href" required-attr ]
M: word set-article-parent swap "help-parent" set-word-prop ;
: $doc-path ( article -- )
- help-path dup empty? [
- drop
- ] [
+ help-path [
[
help-path-style get [
"Parent topics: " write $links
] with-style
] ($block)
- ] if ;
+ ] unless-empty ;
: $title ( topic -- )
title-style get [
sort-articles [ \ $subsection swap 2array ] map print-element ;
: $index ( element -- )
- first call dup empty?
- [ drop ] [ ($index) ] if ;
+ first call [ ($index) ] unless-empty ;
: $about ( element -- )
first vocab-help [ 1array $subsection ] when* ;
] with-scope ;
: typos. ( assoc -- )
- dup empty? [
- drop
+ [
"==== ALL CHECKS PASSED" print
] [
[
swap vocab-heading.
[ error. nl ] each
] assoc-each
- ] if ;
+ ] if-empty ;
: help-lint ( prefix -- ) run-help-lint typos. ;
! Element types are words whose name begins with $.
PREDICATE: simple-element < array
- dup empty? [ drop t ] [ first word? not ] if ;
+ [ t ] [ first word? not ] if-empty ;
SYMBOL: last-element
SYMBOL: span
dup [ "related" set-word-prop ] curry each ;
: $related ( element -- )
- first dup "related" word-prop remove dup empty?
- [ drop ] [ $see-also ] if ;
+ first dup "related" word-prop remove
+ [ $see-also ] unless-empty ;
: ($grid) ( style quot -- )
[
dup length <reversed>
[ (picker) 2array ] 2map
[ drop object eq? not ] assoc-filter
- dup empty? [ drop [ t ] ] [
+ [ [ t ] ] [
[ (make-specializer) ] { } assoc>map
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
- ] if ;
+ ] if-empty ;
: specializer-cases ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
] make-css ;
: span-tag ( style quot -- )
- over span-css-style dup empty? [
- drop call
+ over span-css-style [
+ call
] [
<span =style span> call </span>
- ] if ; inline
+ ] if-empty ; inline
: format-html-span ( string style stream -- )
stream>> [
] make-css ;
: div-tag ( style quot -- )
- swap div-css-style dup empty? [
- drop call
+ swap div-css-style [
+ call
] [
<div =style div> call </div>
- ] if ; inline
+ ] if-empty ; inline
: format-html-div ( string style stream -- )
stream>> [
: describe* ( obj mirror keys -- )
rot summary.
- dup empty? [
- 2drop
+ [
+ drop
] [
dup enum? [ +sequence+ on ] when
standard-table-style [
swap [ -rot describe-row ] curry each-index
] tabular-output
- ] if ;
+ ] if-empty ;
: describe ( obj -- )
dup make-mirror dup sorted-keys describe* ;
<PRIVATE
: parse-inet6 ( string -- seq )
- dup empty? [ drop f ] [
+ [ f ] [
":" split [
hex> [ "Component not a number" throw ] unless*
] B{ } map-as
- ] if ;
+ ] if-empty ;
: pad-inet6 ( string1 string2 -- seq )
2dup [ length ] bi@ + 8 swap -
USING: lcs html.elements kernel qualified ;
FROM: accessors => item>> ;
FROM: io => write ;
-FROM: sequences => each empty? ;
+FROM: sequences => each if-empty ;
FROM: xml.entities => escape-string ;
IN: lcs.diff2html
GENERIC: diff-line ( obj -- )
: write-item ( item -- )
- item>> dup empty? [ drop " " ] [ escape-string ] if write ;
+ item>> [ " " ] [ escape-string ] if-empty write ;
M: retain diff-line
<tr>
UNION: special local quote local-word local-reader local-writer ;
: load-locals-quot ( args -- quot )
- dup empty? [
- drop [ ]
+ [
+ [ ]
] [
dup [ local-reader? ] contains? [
<reversed> [
] [
length [ load-locals ] curry >quotation
] if
- ] if ;
+ ] if-empty ;
: drop-locals-quot ( args -- quot )
- dup empty? [
- drop [ ]
- ] [
- length [ drop-locals ] curry
- ] if ;
+ [ [ ] ] [ length [ drop-locals ] curry ] if-empty ;
: point-free-body ( quot args -- newquot )
>r but-last-slice r> [ localize ] curry map concat ;
] "" make ;\r
\r
: (email-log-report) ( service word-names -- )\r
- dupd ?analyze-log dup empty? [ 2drop ] [\r
+ dupd ?analyze-log [ drop ] [\r
<email>\r
swap >>body\r
insomniac-recipients get >>to\r
insomniac-sender get >>from\r
swap email-subject >>subject\r
send-email\r
- ] if ;\r
+ ] if-empty ;\r
\r
\ (email-log-report) NOTICE add-error-logging\r
\r
swap value>> dup [ swap push ] [ 2drop ] if ;\r
\r
: go-back/forward ( history to from -- )\r
- dup empty?\r
- [ 3drop ]\r
- [ >r dupd (add-history) r> pop swap set-model ] if ;\r
+ [ 2drop ]\r
+ [ >r dupd (add-history) r> pop swap set-model ] if-empty ;\r
\r
: go-back ( history -- )\r
dup [ forward>> ] [ back>> ] bi go-back/forward ;\r
: parse-multiline-string ( end-text -- str )
[
- lexer get column>> swap (parse-multiline-string)
- lexer get (>>column)
- ] "" make rest but-last ;
+ lexer get [ swap (parse-multiline-string) ] change-column drop
+ ] "" make rest-slice but-last ;
: <"
"\">" parse-multiline-string parsed ; parsing
[ write-in nl ] when* ;
: use. ( seq -- )
- dup empty? [ drop ] [
+ [
natural-sort [
\ USING: pprint-word
[ pprint-vocab ] each
\ ; pprint-word
] with-pprint nl
- ] if ;
+ ] unless-empty ;
: vocabs. ( in use -- )
dupd remove [ { "syntax" "scratchpad" } member? not ] filter
"word-style" set-word-prop
: remove-step-into ( word -- )
- building get dup empty? [ drop ] [ nip pop wrapped>> ] if , ;
+ building get [ nip pop wrapped>> ] unless-empty , ;
: (remove-breakpoints) ( quot -- newquot )
[
] keep head ;
: random ( seq -- elt )
- dup empty? [
- drop f
- ] [
+ [ f ] [
[
length dup log2 7 + 8 /i
random-bytes byte-array>bignum swap mod
] keep nth
- ] if ;
+ ] if-empty ;
: delete-random ( seq -- elt )
[ length random ] keep [ nth ] 2keep delete-nth ;
: push-d ( obj -- ) meta-d get push ;
: pop-d ( -- obj )
- meta-d get dup empty? [
- drop <value> dup 1array #introduce, d-in inc
- ] [ pop ] if ;
+ meta-d get [
+ <value> dup 1array #introduce, d-in inc
+ ] [ pop ] if-empty ;
: peek-d ( -- obj ) pop-d dup push-d ;
: output-r ( seq -- ) meta-r get push-all ;
: pop-literal ( -- rstate obj )
- pop-d [ 1array #drop, ] [ literal [ recursion>> ] [ value>> ] bi ] bi ;
+ pop-d
+ [ 1array #drop, ]
+ [ literal [ recursion>> ] [ value>> ] bi ] bi ;
GENERIC: apply-object ( obj -- )
: unify-values ( values -- phi-out )
remove-bottom
- dup empty? [ drop <value> ] [
+ [ <value> ] [
[ known ] map dup all-eq?
[ first make-known ] [ drop <value> ] if
- ] if ;
+ ] if-empty ;
: phi-outputs ( phi-in -- stack )
flip [ unify-values ] map ;
SYMBOL: quotations
: unify-branches ( ins stacks -- in phi-in phi-out )
- zip dup empty? [ drop 0 { } { } ] [
+ zip [ 0 { } { } ] [
[ keys supremum ] [ ] [ balanced? ] tri
[ dupd phi-inputs dup phi-outputs ]
[ quotations get unbalanced-branches-error ]
if
- ] if ;
+ ] if-empty ;
: branch-variable ( seq symbol -- seq )
'[ , _ at ] map ;
M: inference-error error.
[
- rstate>> dup empty?
- [ drop ] [ "Nesting:" print stack. ] if
+ rstate>>
+ [ "Nesting:" print stack. ] unless-empty
] [ error>> error. ] bi ;
TUPLE: literal-expected ;
\ cond [ cond>quot ] 1 define-transform
\ case [
- dup empty? [
- drop [ no-case ]
+ [
+ [ no-case ]
] [
dup peek quotation? [
dup peek swap but-last
] [
[ no-case ] swap
] if case>quot
- ] if
+ ] if-empty
] 1 define-transform
\ cleave [ cleave>quot ] 1 define-transform
: deploy-config ( vocab -- assoc )
dup default-config swap
dup deploy-config-path vocab-file-contents
- parse-fresh dup empty? [ drop ] [ first assoc-union ] if ;
+ parse-fresh [ first assoc-union ] unless-empty ;
: set-deploy-config ( assoc vocab -- )
>r unparse-use string-lines r>
: test-failures. ( assoc -- )
[
nl
- dup empty? [
- drop
+ [
"==== ALL TESTS PASSED" print
] [
"==== FAILING TESTS:" print
swap vocab-heading.
[ failure. nl ] each
] assoc-each
- ] if
+ ] if-empty
] [
"==== NOTHING TO TEST" print
] if* ;
: run-tests ( prefix -- failures )
- child-vocabs dup empty? [ drop f ] [
+ child-vocabs [ f ] [
[ dup run-test ] { } map>assoc
[ second empty? not ] filter
- ] if ;
+ ] if-empty ;
: test ( prefix -- )
run-tests test-failures. ;
: vocabs. ( assoc -- )
[
- dup empty? [
- 2drop
+ [
+ drop
] [
swap root-heading.
standard-table-style [
vocab-headings. [ vocab. ] each
] ($grid)
- ] if
+ ] if-empty
] assoc-each ;
: describe-summary ( vocab -- )
] when* ;
: describe-words ( vocab -- )
- words dup empty? [
+ words [
"Words" $heading
- dup natural-sort $links
- ] unless drop ;
+ natural-sort $links
+ ] unless-empty ;
: vocab-xref ( vocab quot -- vocabs )
>r dup vocab-name swap words [ generic? not ] filter r> map
: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
: describe-uses ( vocab -- )
- vocab-uses dup empty? [
+ vocab-uses [
"Uses" $heading
- dup $vocab-links
- ] unless drop ;
+ $vocab-links
+ ] unless-empty ;
: describe-usage ( vocab -- )
- vocab-usage dup empty? [
+ vocab-usage [
"Used by" $heading
- dup $vocab-links
- ] unless drop ;
+ $vocab-links
+ ] unless-empty ;
: $describe-vocab ( element -- )
first
\r
: vocab-summary ( vocab -- summary )\r
dup dup vocab-summary-path vocab-file-contents\r
- dup empty? [\r
- drop vocab-name " vocabulary" append\r
+ [\r
+ vocab-name " vocabulary" append\r
] [\r
nip first\r
- ] if ;\r
+ ] if-empty ;\r
\r
M: vocab summary\r
[\r
\r
: (all-child-vocabs) ( root name -- vocabs )\r
[ vocab-dir append-path subdirs ] keep\r
- dup empty? [\r
- drop\r
- ] [\r
+ [\r
swap [ "." swap 3append ] with map\r
- ] if ;\r
+ ] unless-empty ;\r
\r
: vocabs-in-dir ( root name -- )\r
dupd (all-child-vocabs) [\r
: step-back-msg ( continuation -- continuation' )
walker-history tget
[ pop* ]
- [ dup empty? [ drop ] [ nip pop ] if ] bi ;
+ [ [ nip pop ] unless-empty ] bi ;
: walker-suspended ( continuation -- continuation' )
+suspended+ set-status
: drag-gesture ( -- )
hand-buttons get-global
- dup empty? [ drop ] [ first <drag> button-gesture ] if ;
+ [ first <drag> button-gesture ] unless-empty ;
SYMBOL: drag-timer
: modifier ( mod modifiers -- seq )
[ second swap bitand 0 > ] with filter
- 0 <column> prune dup empty? [ drop f ] [ >array ] if ;
+ 0 <column> prune [ f ] [ >array ] if-empty ;
: drag-loc ( -- loc )
hand-loc get-global hand-click-loc get-global v- ;
evaluate-input ;
: listener-run-files ( seq -- )
- dup empty? [
- drop
- ] [
+ [
[ [ run-file ] each ] curry call-listener
- ] if ;
+ ] unless-empty ;
: com-end ( listener -- )
input>> interactor-eof ;
nip swap length or 1+ ;
: (>graphemes) ( str -- )
- dup empty? [ drop ] [
+ [
dup first-grapheme cut-slice
swap , (>graphemes)
- ] if ;
+ ] unless-empty ;
: >graphemes ( str -- graphemes )
[ (>graphemes) ] { } make ;
"windows.com.wrapper.callbacks" create ;
: (finish-thunk) ( param-count thunk quot -- thunked-quot )
- [ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ]
+ [ [ drop [ ] ] [ swap 1- '[ , , ndip ] ] if-empty ]
dip compose ;
: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words )
T{ name f "" "encoding" f }
T{ name f "" "standalone" f }
} diff
- dup empty? [ drop ] [ <extra-attrs> throw ] if ;
+ [ <extra-attrs> throw ] unless-empty ;
: good-version ( version -- version )
dup { "1.0" "1.1" } member? [ <bad-version> throw ] unless ;
: ?filter-children ( children -- no-whitespace )\r
xml-pprint? get [\r
[ dup string? [ trim-whitespace ] when ] map\r
- [ dup empty? swap string? and not ] filter\r
+ [ [ empty? ] [ string? ] bi and not ] filter\r
] when ;\r
\r
: print-name ( name -- )\r
\r
: min-class ( class seq -- class/f )\r
over [ classes-intersect? ] curry filter\r
- dup empty? [ 2drop f ] [\r
+ [ drop f ] [\r
tuck [ class<= ] with all? [ peek ] [ drop f ] if\r
- ] if ;\r
+ ] if-empty ;\r
\r
GENERIC: (flatten-class) ( class -- )\r
\r
M: anonymous-intersection (flatten-class)
participants>> [ flatten-builtin-class ] map
- dup empty? [
- drop builtins get sift [ (flatten-class) ] each
+ [
+ builtins get sift [ (flatten-class) ] each
] [
unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
- ] if ;
+ ] if-empty ;
M: anonymous-complement (flatten-class)
drop builtins get sift [ (flatten-class) ] each ;
"metaclass" word-prop intersection-class eq? ;
: intersection-predicate-quot ( members -- quot )
- dup empty? [
- drop [ drop t ]
+ [
+ [ drop t ]
] [
unclip "predicate" word-prop swap [
"predicate" word-prop [ dup ] swap [ not ] 3append
[ drop f ]
] { } map>assoc alist>quot
- ] if ;
+ ] if-empty ;
: define-intersection-predicate ( class -- )
dup participants intersection-predicate-quot define-predicate ;
: check-duplicate-slots ( slots -- )
slot-names duplicates
- dup empty? [ drop ] [ duplicate-slot-names ] if ;
+ [ duplicate-slot-names ] unless-empty ;
ERROR: invalid-slot-name name ;
"metaclass" word-prop union-class eq? ;
: union-predicate-quot ( members -- quot )
- dup empty? [
- drop [ drop f ]
+ [
+ [ drop f ]
] [
unclip "predicate" word-prop swap [
"predicate" word-prop [ dup ] prepend
[ drop t ]
] { } map>assoc alist>quot
- ] if ;
+ ] if-empty ;
: define-union-predicate ( class -- )
dup members union-predicate-quot define-predicate ;
: dispose-each ( seq -- )
[
[ [ dispose ] curry [ , ] recover ] each
- ] { } make dup empty? [ drop ] [ peek rethrow ] if ;
+ ] { } make [ peek rethrow ] unless-empty ;
: with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline
HOOK: root-directory? io-backend ( path -- ? )
M: object root-directory? ( path -- ? )
- dup empty? [ drop f ] [ [ path-separator? ] all? ] if ;
+ [ f ] [ [ path-separator? ] all? ] if-empty ;
ERROR: no-parent-directory path ;
: head-path-separator? ( path1 ? -- ?' )
[
- dup empty? [ drop t ] [ first path-separator? ] if
+ [ t ] [ first path-separator? ] if-empty
] [
drop f
] if ;
<string-writer> swap [ output-stream get ] compose with-output-stream*
>string ; inline
-M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ;
+M: growable stream-read1 [ f ] [ pop ] if-empty ;
: harden-as ( seq growble-exemplar -- newseq )
underlying>> like ;
] if ;
M: growable stream-read
- dup empty? [
- 2drop f
+ [
+ drop f
] [
[ length swap - 0 max ] keep
[ swap growable-read-until ] 2keep
set-length
- ] if ;
+ ] if-empty ;
M: growable stream-read-partial
stream-read ;
"6"
} ;
+HELP: when-empty
+{ $values
+ { "seq" sequence } { "quot1" "the first quotation of an " { $link if-empty } } }
+{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and the " { $snippet "quot1" } " is called." }
+{ $examples "This word is equivalent to " { $link if-empty } " with an empty second quotation:"
+ { $example
+ "USING: sequences prettyprint ;"
+ "{ } [ { 4 5 6 } ] [ ] if-empty ."
+ "{ 4 5 6 }"
+ }
+ { $example
+ "USING: sequences prettyprint ;"
+ "{ } [ { 4 5 6 } ] when-empty ."
+ "{ 4 5 6 }"
+ }
+} ;
+
+HELP: unless-empty
+{ $values
+ { "seq" sequence } { "quot2" "the second quotation of an " { $link if-empty } } }
+{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped. Otherwise, the " { $snippet "quot2" } " is called on the sequence.." }
+{ $examples "This word is equivalent to " { $link if-empty } " with an empty first quotation:"
+ { $example
+ "USING: sequences prettyprint ;"
+ "{ 4 5 6 } [ ] [ sum ] if-empty ."
+ "15"
+ }
+ { $example
+ "USING: sequences prettyprint ;"
+ "{ 4 5 6 } [ sum ] unless-empty ."
+ "15"
+ }
+} ;
+
+{ if-empty when-empty unless-empty } related-words
+
HELP: delete-all
{ $values { "seq" "a resizable sequence" } }
{ $description "Resizes the sequence to zero length, removing all elements. Not all sequences are resizable." }
: when-empty ( seq quot1 -- ) [ ] if-empty ; inline
-: unless-empty ( seq quot1 -- ) [ ] swap if-empty ; inline
+: unless-empty ( seq quot2 -- ) [ ] swap if-empty ; inline
: delete-all ( seq -- ) 0 swap set-length ;
! The f object supports the sequence protocol trivially
M: f length drop 0 ;
M: f nth-unsafe nip ;
-M: f like drop dup empty? [ drop f ] when ;
+M: f like drop [ f ] when-empty ;
INSTANCE: f immutable-sequence
0 [ length + ] reduce ;
: concat ( seq -- newseq )
- dup empty? [
- drop { }
+ [
+ { }
] [
[ sum-lengths ] keep
[ first new-resizable ] keep
[ [ over push-all ] each ] keep
first like
- ] if ;
+ ] if-empty ;
: joined-length ( seq glue -- n )
>r dup sum-lengths swap length 1 [-] r> length * + ;
[ amb-integer ] [ nth ] bi ;\r
\r
: amb ( seq -- elt )\r
- dup empty?\r
- [ drop fail f ]\r
- [ unsafe-amb ] if ; inline\r
+ [ fail f ]\r
+ [ unsafe-amb ] if-empty ; inline\r
\r
MACRO: amb-execute ( seq -- quot )\r
[ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi\r
[ first - ] [ second ] bi ;
M: multi-cord virtual-seq
- seqs>> dup empty? [ drop f ] [ first second ] if ;
+ seqs>> [ f ] [ first second ] if-empty ;
: <cord> ( seqs -- cord )
dup length 2 = [
buttons-matching-hash device-elements-matching length ;
: ?axis ( device hash -- axis/f )
- device-elements-matching dup empty? [ drop f ] [ first ] if ;
+ device-elements-matching [ f ] [ first ] if-empty ;
: ?x-axis ( device -- ? )
x-axis-matching-hash ?axis ;
[ get-char CHAR: < = ] take-until ;
: parse-text ( -- )
- read-until-< dup empty? [
- drop
- ] [
+ read-until-< [
make-text-tag push-tag
- ] if ;
+ ] unless-empty ;
: (parse-attributes) ( -- )
read-whitespace*
drop "The word cannot be used in pattern matching" ;
: next ( revquot -- revquot* first )
- dup empty?
[ "Badly formed math inverse" throw ]
- [ unclip-slice ] if ;
+ [ unclip-slice ] if-empty ;
: constant-word? ( word -- ? )
stack-effect
"pop-inverse" word-prop compose call ;
: (undo) ( revquot -- )
- dup empty? [ drop ]
- [ unclip-slice inverse % (undo) ] if ;
+ [ unclip-slice inverse % (undo) ] unless-empty ;
: [undo] ( quot -- undo )
flatten fold reverse [ (undo) ] [ ] make ;
"irc.ui.commands" require\r
\r
: command ( string string -- string command )\r
- dup empty? [ drop "say" ] when\r
+ [ "say" ] when-empty\r
dup "irc.ui.commands" lookup\r
[ nip ]\r
[ " " append prepend "quote" "irc.ui.commands" lookup ] if* ;\r
: dark-green T{ rgba f 0.0 0.5 0.0 1 } ;\r
\r
: dot-or-parens ( string -- string )\r
- dup empty? [ drop "." ]\r
- [ "(" prepend ")" append ] if ;\r
+ [ "." ]\r
+ [ "(" prepend ")" append ] if-empty ;\r
\r
GENERIC: write-irc ( irc-message -- )\r
\r
: x.dy ( x y -- vec ) (d) wedge -1 alt*n ;
: (d) ( product -- value )
- dup empty?
- [ drop H{ } ] [ unclip swap [ x.dy ] 2keep dx.y alt+ ] if ;
+ [ H{ } ] [ unclip swap [ x.dy ] 2keep dx.y alt+ ] if-empty ;
: linear-op ( vec quot -- vec )
[
: m'.m ( matrix -- matrix' ) dup flip swap m. ;
: empty-matrix? ( matrix -- ? )
- dup empty? [ drop t ] [ first empty? ] if ;
+ [ t ] [ first empty? ] if-empty ;
: ?m+ ( m1 m2 -- m3 )
over empty-matrix? [
: 2pad-right ( p p n -- p p ) 0 [ pad-right swap ] 2keep pad-right swap ;
: pextend ( p p -- p p ) 2dup [ length ] bi@ max 2pad-right ;
: pextend-left ( p p -- p p ) 2dup [ length ] bi@ max 2pad-left ;
-: unempty ( seq -- seq ) dup empty? [ drop { 0 } ] when ;
+: unempty ( seq -- seq ) [ { 0 } ] when-empty ;
: 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ;
PRIVATE>
: (count) ( n d -- n' )
[ (factor) ] { } make
- dup empty? [ drop ] [ [ first ] keep length 2array , ] if ;
+ [ [ first ] keep length 2array , ] unless-empty ;
: (unique) ( n d -- n' )
[ (factor) ] { } make
- dup empty? [ drop ] [ first , ] if ;
+ [ first , ] unless-empty ;
: (factors) ( quot list n -- )
dup 1 > [ swap uncons swap >r pick call r> swap (factors) ] [ 3drop ] if ;
: text-with-scale ( index seq -- str )
dupd nth 3digits>text swap
- scale-numbers dup empty? [
- drop
- ] [
+ scale-numbers [
" " swap 3append
- ] if ;
+ ] unless-empty ;
: append-with-conjunction ( str1 str2 -- newstr )
over length zero? [
: parse-decimal ( str -- ratio )
"." split1
>r dup "-" head? [ drop t "0" ] [ f swap ] if r>
- [ dup empty? [ drop "0" ] when ] bi@
+ [ [ "0" ] when-empty ] bi@
dup length
>r [ dup string>number [ nip ] [ not-a-decimal ] if* ] bi@ r>
10 swap ^ / + swap [ neg ] when ;
dup length <reversed>
[ picker 2array ] 2map
[ drop object eq? not ] assoc-filter
- dup empty? [ drop [ t ] ] [
+ [ [ t ] ] [
[ (multi-predicate) ] { } assoc>map
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
- ] if ;
+ ] if-empty ;
: argument-count ( methods -- n )
keys 0 [ length max ] reduce ;
"\0" read-until [ drop f ] unless ;
: read-c-string* ( n -- str/f )
- read [ zero? ] trim-right dup empty? [ drop f ] when ;
+ read [ zero? ] trim-right [ f ] when-empty ;
: (read-128-ber) ( n -- n )
read1
} cond ;
: -ion ( str -- newstr )
- dup empty? [
- drop "ion"
+ [
+ "ion"
] [
dup "st" last-is? [ "ion" append ] unless
- ] if ;
+ ] if-empty ;
: step4 ( str -- newstr )
dup {
: find-source ( seq -- elt )
unzip diff prune
- dup empty? [ "Topological sort failed" throw ] [ first ] if ;
+ [ "Topological sort failed" throw ] [ first ] if-empty ;
: remove-source ( seq elt -- seq )
[ swap member? not ] curry filter ;
dup length 1 > [
dup find-source dup , remove-source (topological-sort)
] [
- dup empty? [ drop ] [ first [ , ] each ] if
+ [ first [ , ] each ] unless-empty
] if ;
PRIVATE>
: vocab-noise-factor ( vocab -- factor )\r
words flatten-generics\r
[ word-noise-factor dup 20 < [ drop 0 ] when ] map\r
- dup empty? [ drop 0 ] [\r
+ [ 0 ] [\r
[ [ sum ] [ length 5 max ] bi /i ]\r
[ supremum ]\r
bi +\r
- ] if ;\r
+ ] if-empty ;\r
\r
: noisy-vocabs ( -- alist )\r
vocabs [ dup vocab-noise-factor ] { } map>assoc\r
"passed to the quotation given to each-withn for each element in the sequence."\r
} \r
{ $see-also map-withn } ;\r
-\r
-HELP: if-seq\r
-{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } }\r
-{ $description "Makes an implicit check if the sequence is empty. If the sequence has any elements, " { $snippet "quot1" } " is called on it. Otherwise, the empty sequence is dropped and " { $snippet "quot2" } " is called." }\r
-{ $example\r
- "USING: kernel prettyprint sequences sequences.lib ;"\r
- "{ 1 2 3 } [ sum ] [ \"empty sequence\" throw ] if-seq ."\r
- "6"\r
-} ;\r
-\r
-HELP: if-empty\r
-{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } }\r
-{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and " { $snippet "quot1" } " is called. Otherwise, if the sequence has any elements, " { $snippet "quot2" } " is called on it." }\r
-{ $example\r
- "USING: kernel prettyprint sequences sequences.lib ;"\r
- "{ 1 2 3 } [ \"empty sequence\" ] [ sum ] if-empty ."\r
- "6"\r
-} ;\r
-\r
-{ if-seq if-empty } related-words\r
[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
-
-[ "empty" ] [ { } [ "not empty" ] [ "empty" ] if-seq ] unit-test
-[ { 1 } "not empty" ] [ { 1 } [ "not empty" ] [ "empty" ] if-seq ] unit-test
: ?nth* ( n seq -- elt/f ? )
2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable
-
-: if-seq ( seq quot1 quot2 -- ) [ f like ] 2dip if* ; inline
-
-: if-empty ( seq quot1 quot2 -- ) swap if-seq ; inline
-
-: when-empty ( seq quot1 -- ) [ ] if-empty ; inline
-
-: unless-empty ( seq quot1 -- ) [ ] swap if-empty ; inline
-
[ remove-one ] curry bi@ ;
: symbolic-reduce ( seq seq -- seq seq )
- 2dup intersect dup empty?
- [ drop ] [ first 2remove-one symbolic-reduce ] if ;
+ 2dup intersect
+ [ first 2remove-one symbolic-reduce ] unless-empty ;
: <dimensioned> ( n top bot -- obj )
symbolic-reduce
DEFER: >>
: attributes-parsed ( accum quot -- accum )
- dup empty? [ drop f parsed ] [
+ [ f parsed ] [
>r \ >r parsed r> parsed
[ H{ } make-assoc r> swap ] [ parsed ] each
- ] if ;
+ ] if-empty ;
: <<
parsed-name [
projects / factor.git / commitdiff