From 1d8bd74d0f712015ec8458a798a21aa00dc0165e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 16 Oct 2007 04:15:16 -0400 Subject: [PATCH] new unfold word --- core/bootstrap/image/image.factor | 12 +++--------- core/classes/classes.factor | 10 ++++------ core/io/io.factor | 4 +--- core/kernel/kernel.factor | 5 +++++ core/sequences/sequences.factor | 7 +++++++ core/tuples/tuples.factor | 3 ++- extra/concurrency/concurrency.factor | 12 +++--------- extra/help/crossref/crossref.factor | 5 +---- extra/io/sockets/impl/impl.factor | 7 +++---- extra/serialize/serialize-tests.factor | 10 ++++++++++ extra/serialize/serialize.factor | 5 +---- extra/store/blob/blob.factor | 2 +- extra/ui/gadgets/gadgets.factor | 10 ++-------- extra/xml-rpc/xml-rpc.factor | 2 +- 14 files changed, 44 insertions(+), 50 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index c749ec3dad..423b25b69e 100644 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -153,17 +153,11 @@ GENERIC: ' ( obj -- ptr ) : bignum-radix bignum-bits 2^ 1- ; -: (bignum>seq) ( n -- ) - dup zero? [ - drop - ] [ - dup bignum-radix bitand , - bignum-bits neg shift (bignum>seq) - ] if ; - : bignum>seq ( n -- seq ) #! n is positive or zero. - [ (bignum>seq) ] { } make ; + [ dup 0 > ] + [ dup bignum-bits neg shift swap bignum-radix bitand ] + { } unfold ; : emit-bignum ( n -- ) [ 0 < 1 0 ? ] keep abs bignum>seq diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 41be3dd484..a17866aa3b 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -127,15 +127,13 @@ DEFER: (class<) curry* subset empty? ] curry find [ "Topological sort failed" throw ] unless* ; -: (sort-classes) ( vec -- ) - dup empty? - [ drop ] - [ dup largest-class , over delete-nth (sort-classes) ] if ; - PRIVATE> : sort-classes ( seq -- newseq ) - [ >vector (sort-classes) ] { } make ; + >vector + [ dup empty? not ] + [ dup largest-class >r over delete-nth r> ] + { } unfold ; : class-or ( class1 class2 -- class ) { diff --git a/core/io/io.factor b/core/io/io.factor index 4580d83241..d00a208e4e 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -85,10 +85,8 @@ SYMBOL: stdio : write-object ( str obj -- ) presented associate format ; -: lines-loop ( -- ) readln [ , lines-loop ] when* ; - : lines ( stream -- seq ) - [ [ lines-loop ] { } make ] with-stream ; + [ [ readln dup ] [ ] { } unfold ] with-stream ; : contents ( stream -- str ) 2048 [ stream-copy ] keep >string ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index ba054140c7..88ca0a64f7 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -60,6 +60,11 @@ DEFER: if : 2apply ( x y quot -- ) tuck 2slip call ; inline +: while ( pred body tail -- ) + >r >r dup slip r> r> roll + [ >r tuck 2slip r> while ] + [ 2nip call ] if ; inline + ! Quotation building : 2curry ( obj1 obj2 quot -- curry ) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 3c63cd5cb4..5d4e23db7c 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -655,3 +655,10 @@ PRIVATE> : trim ( seq quot -- newseq ) [ ltrim ] keep rtrim ; inline + +: unfold ( obj pred quot exemplar -- seq ) + [ + 10 swap new-resizable [ + [ push ] curry compose [ drop ] while + ] keep + ] keep like ; inline diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index ce32ef3cd5..edd37abb65 100644 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -106,7 +106,8 @@ M: tuple equal? : (delegates) ( obj -- ) [ dup , delegate (delegates) ] when* ; -: delegates ( obj -- seq ) [ (delegates) ] { } make ; +: delegates ( obj -- seq ) + [ dup ] [ [ delegate ] keep ] { } unfold ; : is? ( obj quot -- ? ) >r delegates r> contains? ; inline diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index 14f74f5d55..94bda9e720 100644 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -40,17 +40,11 @@ PRIVATE> (mailbox-block-if-empty) mailbox-data dlist-pop-front ; - : mailbox-get-all ( mailbox -- array ) (mailbox-block-if-empty) - [ (mailbox-get-all) ] { } make ; + [ dup mailbox-empty? ] + [ dup mailbox-data dlist-pop-front ] + { } unfold ; : while-mailbox-empty ( mailbox quot -- ) over mailbox-empty? [ diff --git a/extra/help/crossref/crossref.factor b/extra/help/crossref/crossref.factor index 2dae83ffee..9597a51471 100644 --- a/extra/help/crossref/crossref.factor +++ b/extra/help/crossref/crossref.factor @@ -13,11 +13,8 @@ M: link uses { $subsection $link $see-also } collect-elements [ \ f or ] map ; -: (help-path) ( topic -- ) - article-parent [ dup , (help-path) ] when* ; - : help-path ( topic -- seq ) - [ (help-path) ] { } make ; + [ dup ] [ [ article-parent ] keep ] { } unfold 1 tail ; : set-article-parents ( parent article -- ) article-children [ set-article-parent ] curry* each ; diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor index e99c8d213a..b03ec94a6b 100644 --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -94,11 +94,10 @@ M: f parse-sockaddr nip ; swap addrinfo-family addrspec-of-family parse-sockaddr ; -: addrspec, ( addrinfo -- ) - [ dup addrinfo>addrspec , addrinfo-next addrspec, ] when* ; - : parse-addrinfo-list ( addrinfo -- seq ) - [ addrspec, ] { } make [ ] subset ; + [ dup ] + [ dup addrinfo-next swap addrinfo>addrspec ] + { } unfold [ ] subset ; M: object resolve-host ( host serv passive? -- seq ) >r dup integer? [ number>string ] when diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor index f40499f534..a713840a20 100644 --- a/extra/serialize/serialize-tests.factor +++ b/extra/serialize/serialize-tests.factor @@ -59,3 +59,13 @@ C: serialize-test [ t ] [ objects [ check-serialize-2 ] all? ] unit-test [ t ] [ pi check-serialize-1 ] unit-test + +[ t ] [ + { 1 2 3 } [ + [ + dup (serialize) (serialize) + ] with-serialized + ] string-out [ + deserialize-sequence all-eq? + ] string-in +] unit-test diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index 370033152b..632ed763fb 100644 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -260,11 +260,8 @@ DEFER: (deserialize) ( -- obj ) : with-serialized ( quot -- ) V{ } clone serialized rot with-variable ; inline -: (deserialize-sequence) - deserialize* [ , (deserialize-sequence) ] [ drop ] if ; - : deserialize-sequence ( -- seq ) - [ (deserialize-sequence) ] { } make ; + [ [ deserialize* ] [ ] { } unfold ] with-serialized ; : deserialize ( -- obj ) [ (deserialize) ] with-serialized ; diff --git a/extra/store/blob/blob.factor b/extra/store/blob/blob.factor index a903471c8f..9cec77c6c2 100644 --- a/extra/store/blob/blob.factor +++ b/extra/store/blob/blob.factor @@ -11,7 +11,7 @@ IN: store.blob : (load-blob) ( path -- seq/f ) dup exists? [ [ - [ deserialize-sequence ] with-serialized + deserialize-sequence ] with-stream ] [ drop f diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 3d3dd4244b..214c5b4921 100644 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -285,11 +285,8 @@ M: gadget ungraft* drop ; : add-gadgets ( seq parent -- ) swap [ over (add-gadget) ] each relayout ; -: (parents) ( gadget -- ) - [ dup , gadget-parent (parents) ] when* ; - : parents ( gadget -- seq ) - [ (parents) ] { } make ; + [ dup ] [ [ gadget-parent ] keep ] { } unfold ; : each-parent ( gadget quot -- ? ) >r parents r> all? ; inline @@ -335,11 +332,8 @@ M: f request-focus-on 2drop ; : request-focus ( gadget -- ) dup focusable-child swap request-focus-on ; -: (focus-path) ( gadget -- ) - [ dup , gadget-focus (focus-path) ] when* ; - : focus-path ( world -- seq ) - [ (focus-path) ] { } make ; + [ dup ] [ [ gadget-focus ] keep ] { } unfold ; : make-gadget ( quot gadget -- gadget ) [ \ make-gadget rot with-variable ] keep ; inline diff --git a/extra/xml-rpc/xml-rpc.factor b/extra/xml-rpc/xml-rpc.factor index 3e04a8dd85..a7603a939e 100644 --- a/extra/xml-rpc/xml-rpc.factor +++ b/extra/xml-rpc/xml-rpc.factor @@ -35,7 +35,7 @@ M: string item>xml ! This should change < and & 2array "member" build-tag* ; M: hashtable item>xml - [ [ struct-member , ] assoc-each ] { } make + [ struct-member ] { } assoc>map "struct" build-tag* ; M: array item>xml