Change unfold word

release
Slava Pestov 2007-11-04 17:32:01 -05:00
parent 8e8273a316
commit dfeb154bb1
9 changed files with 24 additions and 24 deletions

View File

@ -157,7 +157,7 @@ GENERIC: ' ( obj -- ptr )
#! n is positive or zero. #! n is positive or zero.
[ dup 0 > ] [ dup 0 > ]
[ dup bignum-bits neg shift swap bignum-radix bitand ] [ dup bignum-bits neg shift swap bignum-radix bitand ]
{ } unfold ; [ ] unfold nip ;
: emit-bignum ( n -- ) : emit-bignum ( n -- )
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq

View File

@ -133,7 +133,7 @@ PRIVATE>
>vector >vector
[ dup empty? not ] [ dup empty? not ]
[ dup largest-class >r over delete-nth r> ] [ dup largest-class >r over delete-nth r> ]
{ } unfold ; [ ] unfold nip ;
: class-or ( class1 class2 -- class ) : class-or ( class1 class2 -- class )
{ {

View File

@ -86,7 +86,7 @@ SYMBOL: stdio
presented associate format ; presented associate format ;
: lines ( stream -- seq ) : lines ( stream -- seq )
[ [ readln dup ] [ ] { } unfold ] with-stream ; [ [ readln dup ] [ ] [ drop ] unfold ] with-stream ;
: contents ( stream -- str ) : contents ( stream -- str )
2048 <sbuf> [ stream-copy ] keep >string ; 2048 <sbuf> [ stream-copy ] keep >string ;

View File

@ -414,12 +414,10 @@ PRIVATE>
: interleave ( seq between quot -- ) : interleave ( seq between quot -- )
[ (interleave) ] 2curry iterate-seq 2each ; inline [ (interleave) ] 2curry iterate-seq 2each ; inline
: unfold ( obj pred quot exemplar -- seq ) : unfold ( pred quot tail -- seq )
[ V{ } clone [
10 swap new-resizable [ swap >r [ push ] curry compose r> while
[ push ] curry compose [ drop ] while ] keep { } like ; inline
] keep
] keep like ; inline
: index ( obj seq -- n ) : index ( obj seq -- n )
[ = ] curry* find drop ; [ = ] curry* find drop ;

View File

@ -107,7 +107,7 @@ M: tuple equal?
[ dup , delegate (delegates) ] when* ; [ dup , delegate (delegates) ] when* ;
: delegates ( obj -- seq ) : delegates ( obj -- seq )
[ dup ] [ [ delegate ] keep ] { } unfold ; [ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline : is? ( obj quot -- ? ) >r delegates r> contains? ; inline

View File

@ -60,7 +60,7 @@ PRIVATE>
(mailbox-block-if-empty) (mailbox-block-if-empty)
[ dup mailbox-empty? ] [ dup mailbox-empty? ]
[ dup mailbox-data dlist-pop-front ] [ dup mailbox-data dlist-pop-front ]
{ } unfold ; [ ] unfold nip ;
: mailbox-get-all ( mailbox -- array ) : mailbox-get-all ( mailbox -- array )
f mailbox-get-all* ; f mailbox-get-all* ;

View File

@ -12,7 +12,10 @@ GENERIC: protocol-family ( addrspec -- af )
GENERIC: sockaddr-type ( addrspec -- type ) GENERIC: sockaddr-type ( addrspec -- type )
GENERIC: make-sockaddr ( addrspec -- sockaddr type ) GENERIC: make-sockaddr ( addrspec -- sockaddr )
: make-sockaddr/size ( addrspec -- sockaddr size )
dup make-sockaddr swap sockaddr-type heap-size ;
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec ) GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
@ -36,16 +39,15 @@ M: inet4 address-size drop 4 ;
M: inet4 protocol-family drop PF_INET ; M: inet4 protocol-family drop PF_INET ;
M: inet4 sockaddr-type drop "sockaddr-in" ; M: inet4 sockaddr-type drop "sockaddr-in" c-type ;
M: inet4 make-sockaddr ( inet -- sockaddr type ) M: inet4 make-sockaddr ( inet -- sockaddr )
"sockaddr-in" <c-object> "sockaddr-in" <c-object>
AF_INET over set-sockaddr-in-family AF_INET over set-sockaddr-in-family
over inet4-port htons over set-sockaddr-in-port over inet4-port htons over set-sockaddr-in-port
over inet4-host over inet4-host
"0.0.0.0" or "0.0.0.0" or
rot inet-pton *uint over set-sockaddr-in-addr rot inet-pton *uint over set-sockaddr-in-addr ;
"sockaddr-in" ;
M: inet4 parse-sockaddr M: inet4 parse-sockaddr
>r dup sockaddr-in-addr <uint> r> inet-ntop >r dup sockaddr-in-addr <uint> r> inet-ntop
@ -65,15 +67,14 @@ M: inet6 address-size drop 16 ;
M: inet6 protocol-family drop PF_INET6 ; M: inet6 protocol-family drop PF_INET6 ;
M: inet6 sockaddr-type drop "sockaddr-in6" ; M: inet6 sockaddr-type drop "sockaddr-in6" c-type ;
M: inet6 make-sockaddr ( inet -- sockaddr type ) M: inet6 make-sockaddr ( inet -- sockaddr )
"sockaddr-in6" <c-object> "sockaddr-in6" <c-object>
AF_INET6 over set-sockaddr-in6-family AF_INET6 over set-sockaddr-in6-family
over inet6-port htons over set-sockaddr-in6-port over inet6-port htons over set-sockaddr-in6-port
over inet6-host "::" or over inet6-host "::" or
rot inet-pton over set-sockaddr-in6-addr rot inet-pton over set-sockaddr-in6-addr ;
"sockaddr-in6" ;
M: inet6 parse-sockaddr M: inet6 parse-sockaddr
>r dup sockaddr-in6-addr r> inet-ntop >r dup sockaddr-in6-addr r> inet-ntop
@ -97,7 +98,7 @@ M: f parse-sockaddr nip ;
: parse-addrinfo-list ( addrinfo -- seq ) : parse-addrinfo-list ( addrinfo -- seq )
[ dup ] [ dup ]
[ dup addrinfo-next swap addrinfo>addrspec ] [ dup addrinfo-next swap addrinfo>addrspec ]
{ } unfold [ ] subset ; [ ] unfold nip [ ] subset ;
M: object resolve-host ( host serv passive? -- seq ) M: object resolve-host ( host serv passive? -- seq )
>r dup integer? [ number>string ] when >r dup integer? [ number>string ] when

View File

@ -20,7 +20,8 @@ M: border pref-dim*
: border-minor-rect ( major border -- rect ) : border-minor-rect ( major border -- rect )
gadget-child pref-dim gadget-child pref-dim
[ >r rect-bounds r> v- 2 v/n v+ ] keep <rect> ; [ >r rect-bounds r> v- [ 2 / >fixnum ] map v+ ] keep
<rect> ;
: scale-rect ( rect vec -- loc dim ) : scale-rect ( rect vec -- loc dim )
[ v* ] curry >r rect-bounds r> 2apply ; [ v* ] curry >r rect-bounds r> 2apply ;

View File

@ -286,7 +286,7 @@ M: gadget ungraft* drop ;
swap [ over (add-gadget) ] each relayout ; swap [ over (add-gadget) ] each relayout ;
: parents ( gadget -- seq ) : parents ( gadget -- seq )
[ dup ] [ [ gadget-parent ] keep ] { } unfold ; [ dup ] [ [ gadget-parent ] keep ] [ ] unfold nip ;
: each-parent ( gadget quot -- ? ) : each-parent ( gadget quot -- ? )
>r parents r> all? ; inline >r parents r> all? ; inline
@ -333,7 +333,7 @@ M: f request-focus-on 2drop ;
dup focusable-child swap request-focus-on ; dup focusable-child swap request-focus-on ;
: focus-path ( world -- seq ) : focus-path ( world -- seq )
[ dup ] [ [ gadget-focus ] keep ] { } unfold ; [ dup ] [ [ gadget-focus ] keep ] [ ] unfold nip ;
: make-gadget ( quot gadget -- gadget ) : make-gadget ( quot gadget -- gadget )
[ \ make-gadget rot with-variable ] keep ; inline [ \ make-gadget rot with-variable ] keep ; inline