From b1d26e100a98ab8a10396046b4ff08ea95c8f75f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 6 Sep 2008 17:10:32 -0500 Subject: [PATCH] use if/when/unless-empty, docs --- core/classes/algebra/algebra.factor | 4 +-- core/classes/builtin/builtin.factor | 6 ++-- core/classes/intersection/intersection.factor | 6 ++-- core/classes/tuple/parser/parser.factor | 2 +- core/classes/union/union.factor | 6 ++-- core/destructors/destructors.factor | 2 +- core/io/files/files.factor | 4 +-- core/io/streams/string/string.factor | 8 ++--- core/sequences/sequences-docs.factor | 36 +++++++++++++++++++ core/sequences/sequences.factor | 10 +++--- 10 files changed, 60 insertions(+), 24 deletions(-) diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 0f419678d1..b32bac3a18 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -208,9 +208,9 @@ M: anonymous-complement (classes-intersect?) : min-class ( class seq -- class/f ) over [ classes-intersect? ] curry filter - dup empty? [ 2drop f ] [ + [ drop f ] [ tuck [ class<= ] with all? [ peek ] [ drop f ] if - ] if ; + ] if-empty ; GENERIC: (flatten-class) ( class -- ) diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index b0e4754682..ee687c2939 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -44,11 +44,11 @@ M: builtin-class (classes-intersect?) 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 ; diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index bb7e0adc62..55831fcdb4 100644 --- a/core/classes/intersection/intersection.factor +++ b/core/classes/intersection/intersection.factor @@ -8,14 +8,14 @@ PREDICATE: intersection-class < class "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 ; diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 0865de16c3..531658a5e0 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -26,7 +26,7 @@ ERROR: duplicate-slot-names names ; : check-duplicate-slots ( slots -- ) slot-names duplicates - dup empty? [ drop ] [ duplicate-slot-names ] if ; + [ duplicate-slot-names ] unless-empty ; ERROR: invalid-slot-name name ; diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index fbb1925363..81a0db52be 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -8,14 +8,14 @@ PREDICATE: union-class < class "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 ; diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor index bed1c16bcf..154e1c30ac 100755 --- a/core/destructors/destructors.factor +++ b/core/destructors/destructors.factor @@ -21,7 +21,7 @@ M: object dispose : 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 diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 93405fe7c0..e52799d10a 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -59,7 +59,7 @@ HOOK: (file-appender) io-backend ( path -- stream ) 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 ; @@ -80,7 +80,7 @@ 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 ; diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index 607076b809..b2b75509e9 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -18,7 +18,7 @@ M: growable stream-flush drop ; 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 ; @@ -39,13 +39,13 @@ M: growable stream-read-until ] 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 ; diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 4ada1ece9a..ea713b0814 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -335,6 +335,42 @@ HELP: if-empty "6" } ; +HELP: when-empty +{ $values + { "seq" sequence } { "quot1" quotation } } +{ $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" quotation } } +{ $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." } diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index b7f36eb071..18291aaa70 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -34,7 +34,7 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; : 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 ; @@ -91,7 +91,7 @@ M: sequence set-nth-unsafe set-nth ; ! 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 @@ -630,14 +630,14 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; 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 * + ;