if-empty changes

db4
Doug Coleman 2008-09-06 19:13:59 -05:00
parent e0f7e508aa
commit 8a921c791c
45 changed files with 119 additions and 137 deletions

View File

@ -36,7 +36,7 @@ PRIVATE>
#! 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 )

View File

@ -33,10 +33,10 @@ PRIVATE>
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 ;

View File

@ -120,7 +120,7 @@ M: sha1 checksum-stream ( stream -- sha1 )
: 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 }

View File

@ -28,18 +28,18 @@ DEFER: (tail-call?)
[ 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? ;

View File

@ -32,7 +32,7 @@ M: #shuffle check-node*
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> ;

View File

@ -37,8 +37,8 @@ GENERIC: cleanup* ( node -- node/nodes )
[ 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

View File

@ -15,7 +15,7 @@ M: #branch escape-analysis*
: (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
@ -23,7 +23,7 @@ M: #branch escape-analysis*
[ 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 -- )

View File

@ -205,5 +205,5 @@ M: node normalize* ;
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 ;

View File

@ -237,9 +237,8 @@ DEFER: (value-info-union)
} 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 -- ? )
{

View File

@ -185,7 +185,7 @@ M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
[ 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, ;

View File

@ -87,11 +87,11 @@ M: postgresql-result-null summary ( obj -- str )
{ 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 ;

View File

@ -136,7 +136,7 @@ ERROR: no-sql-type ;
: modifiers ( spec -- string )
modifiers>> [ lookup-modifier ] map " " join
dup empty? [ " " prepend ] unless ;
[ "" ] [ " " prepend ] if-empty ;
HOOK: bind% db ( spec -- )
HOOK: bind# db ( spec obj -- )

View File

@ -48,14 +48,12 @@ M: string error. print ;
] "" 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

View File

@ -14,13 +14,13 @@ DEFER: shallow-fry
: ((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)) ] }
@ -31,7 +31,7 @@ DEFER: shallow-fry
[ swap >r suffix r> (shallow-fry) ]
} case
] if ;
] if-empty ;
: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;

View File

@ -23,11 +23,11 @@ SYMBOL: rest
: render-validation-messages ( -- )
form get errors>>
dup empty? [ drop ] [
[
<ul "errors" =class ul>
[ <li> escape-string write </li> ] each
</ul>
] if ;
] unless-empty ;
CHLOE: validation-messages drop render-validation-messages ;
@ -47,11 +47,11 @@ TUPLE: action rest authorize init display validate submit ;
2tri ;
: set-nested-form ( form name -- )
dup empty? [
drop merge-forms
[
merge-forms
] [
unclip [ set-nested-form ] nest-form
] if ;
] if-empty ;
: restore-validation-errors ( -- )
form cget [

View File

@ -42,8 +42,8 @@ IN: furnace.auth.features.edit-profile
[
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

View File

@ -112,8 +112,7 @@ SYMBOL: exit-continuation
! 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 ]

View File

@ -72,15 +72,13 @@ M: word article-parent "help-parent" word-prop ;
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 [
@ -112,8 +110,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
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* ;

View File

@ -136,15 +136,14 @@ M: help-error error.
] 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. ;

View File

@ -15,7 +15,7 @@ IN: help.markup
! 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
@ -201,8 +201,8 @@ ALIAS: $slot $snippet
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 -- )
[

View File

@ -13,10 +13,10 @@ IN: hints
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 [

View File

@ -88,11 +88,11 @@ TUPLE: html-sub-stream < html-stream style parent ;
] 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>> [
@ -121,11 +121,11 @@ M: html-span-stream dispose
] 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>> [

View File

@ -50,14 +50,14 @@ SYMBOL: +editable+
: 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* ;

View File

@ -95,11 +95,11 @@ M: invalid-inet6 summary drop "Invalid IPv6 address" ;
<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 -

View File

@ -3,14 +3,14 @@
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 "&nbsp;" ] [ escape-string ] if write ;
item>> [ "&nbsp;" ] [ escape-string ] if-empty write ;
M: retain diff-line
<tr>

View File

@ -98,8 +98,8 @@ C: <quote> quote
UNION: special local quote local-word local-reader local-writer ;
: load-locals-quot ( args -- quot )
dup empty? [
drop [ ]
[
[ ]
] [
dup [ local-reader? ] contains? [
<reversed> [
@ -108,14 +108,10 @@ UNION: special local quote local-word local-reader local-writer ;
] [
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 ;

View File

@ -18,14 +18,14 @@ SYMBOL: insomniac-recipients
] "" make ;
: (email-log-report) ( service word-names -- )
dupd ?analyze-log dup empty? [ 2drop ] [
dupd ?analyze-log [ drop ] [
<email>
swap >>body
insomniac-recipients get >>to
insomniac-sender get >>from
swap email-subject >>subject
send-email
] if ;
] if-empty ;
\ (email-log-report) NOTICE add-error-logging

View File

@ -17,9 +17,8 @@ TUPLE: history < model back forward ;
swap value>> dup [ swap push ] [ 2drop ] if ;
: go-back/forward ( history to from -- )
dup empty?
[ 3drop ]
[ >r dupd (add-history) r> pop swap set-model ] if ;
[ 2drop ]
[ >r dupd (add-history) r> pop swap set-model ] if-empty ;
: go-back ( history -- )
dup [ forward>> ] [ back>> ] bi go-back/forward ;

View File

@ -38,13 +38,13 @@ IN: prettyprint
[ 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
@ -98,7 +98,7 @@ SYMBOL: ->
"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 )
[

View File

@ -34,14 +34,12 @@ M: f random-32* ( obj -- * ) no-random-number-generator ;
] 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 ;

View File

@ -11,9 +11,9 @@ IN: stack-checker.backend
: 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 ;
@ -40,7 +40,9 @@ IN: stack-checker.backend
: 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 -- )

View File

@ -31,10 +31,10 @@ SYMBOL: +bottom+
: 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 ;
@ -42,12 +42,12 @@ SYMBOL: +bottom+
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 ;

View File

@ -26,8 +26,8 @@ M: inference-error error-help error>> error-help ;
M: inference-error error.
[
rstate>> dup empty?
[ drop ] [ "Nesting:" print stack. ] if
rstate>>
[ "Nesting:" print stack. ] unless-empty
] [ error>> error. ] bi ;
TUPLE: literal-expected ;

View File

@ -69,15 +69,15 @@ IN: stack-checker.transforms
\ 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

View File

@ -73,7 +73,7 @@ SYMBOL: deploy-image
: 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>

View File

@ -67,8 +67,7 @@ SYMBOL: this-test
: test-failures. ( assoc -- )
[
nl
dup empty? [
drop
[
"==== ALL TESTS PASSED" print
] [
"==== FAILING TESTS:" print
@ -76,16 +75,16 @@ SYMBOL: this-test
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. ;

View File

@ -36,14 +36,14 @@ IN: tools.vocabs.browser
: 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 -- )
@ -98,10 +98,10 @@ C: <vocab-author> vocab-author
] 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
@ -113,16 +113,16 @@ C: <vocab-author> vocab-author
: 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

View File

@ -165,11 +165,11 @@ MEMO: vocab-file-contents ( vocab name -- seq )
: vocab-summary ( vocab -- summary )
dup dup vocab-summary-path vocab-file-contents
dup empty? [
drop vocab-name " vocabulary" append
[
vocab-name " vocabulary" append
] [
nip first
] if ;
] if-empty ;
M: vocab summary
[
@ -212,11 +212,9 @@ M: vocab-link summary vocab-summary ;
: (all-child-vocabs) ( root name -- vocabs )
[ vocab-dir append-path subdirs ] keep
dup empty? [
drop
] [
[
swap [ "." swap 3append ] with map
] if ;
] unless-empty ;
: vocabs-in-dir ( root name -- )
dupd (all-child-vocabs) [

View File

@ -197,7 +197,7 @@ SYMBOL: +stopped+
: 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

View File

@ -108,7 +108,7 @@ SYMBOL: double-click-timeout
: drag-gesture ( -- )
hand-buttons get-global
dup empty? [ drop ] [ first <drag> button-gesture ] if ;
[ first <drag> button-gesture ] unless-empty ;
SYMBOL: drag-timer
@ -170,7 +170,7 @@ 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- ;

View File

@ -72,11 +72,9 @@ M: listener-operation invoke-command ( target command -- )
evaluate-input ;
: listener-run-files ( seq -- )
dup empty? [
drop
] [
[
[ [ run-file ] each ] curry call-listener
] if ;
] unless-empty ;
: com-end ( listener -- )
input>> interactor-eof ;

View File

@ -80,10 +80,10 @@ VALUE: grapheme-table
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 ;

View File

@ -100,7 +100,7 @@ unless
"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 )

View File

@ -164,7 +164,7 @@ SYMBOL: ns-stack
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 ;

View File

@ -34,7 +34,7 @@ SYMBOL: indenter
: ?filter-children ( children -- no-whitespace )
xml-pprint? get [
[ dup string? [ trim-whitespace ] when ] map
[ dup empty? swap string? and not ] filter
[ [ empty? ] [ string? ] bi and not ] filter
] when ;
: print-name ( name -- )