steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Clean up dlists

Slava Pestov 2008-03-20 20:14:07 -05:00
parent 3164c857c7
commit f98dbbbe74
7 changed files with 102 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
core/dlists/dlists-docs.factor
View File

@ -85,7 +85,7 @@ HELP: pop-back*
{ $see-also push-front push-back pop-front pop-front* pop-back } ;
HELP: dlist-find
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }
{ $notes "Returns a boolean to allow dlists to store " { $link f } "."
$nl
@ -93,20 +93,20 @@ HELP: dlist-find
} ;
HELP: dlist-contains?
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "?" "a boolean" } }
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
{ $notes "This operation is O(n)." } ;
HELP: delete-node-if*
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any. Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." }
{ $notes "This operation is O(n)." } ;
HELP: delete-node-if
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } }
{ $description "Like " { $link delete-node-if* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
{ $notes "This operation is O(n)." } ;
HELP: dlist-each
{ $values { "quot" quotation } { "dlist" { $link dlist } } }
{ $values { "dlist" { $link dlist } } { "quot" quotation } }
{ $description "Iterate a " { $link dlist } ", calling quot on each element." } ;

26
core/dlists/dlists-tests.factor
View File

@ -43,20 +43,20 @@ IN: dlists.tests
dlist-front dlist-node-next dlist-node-next
] unit-test
[ f f ] [ <dlist> [ 1 = ] swap dlist-find ] unit-test
[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-find ] unit-test
[ f f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-find ] unit-test
[ f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test
[ f f ] [ <dlist> [ 1 = ] dlist-find ] unit-test
[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] dlist-find ] unit-test
[ f f ] [ <dlist> 1 over push-back [ 2 = ] dlist-find ] unit-test
[ f ] [ <dlist> 1 over push-back [ 2 = ] dlist-contains? ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-contains? ] unit-test
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node-if ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node-if drop dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] delete-node-if ] unit-test
[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test
[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test
[ 0 ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop dlist-length ] unit-test
[ 0 ] [ <dlist> dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test

126
core/dlists/dlists.factor
View File

@ -1,71 +1,67 @@
! Copyright (C) 2007 Mackenzie Straight, Doug Coleman.
! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math sequences ;
USING: combinators kernel math sequences accessors ;
IN: dlists
TUPLE: dlist front back length ;
: <dlist> ( -- obj )
dlist construct-empty
0 over set-dlist-length ;
0 >>length ;
: dlist-empty? ( dlist -- ? ) dlist-front not ;
: dlist-empty? ( dlist -- ? ) front>> not ;
<PRIVATE
TUPLE: dlist-node obj prev next ;
C: <dlist-node> dlist-node
: inc-length ( dlist -- )
[ dlist-length 1+ ] keep set-dlist-length ; inline
[ 1+ ] change-length drop ; inline
: dec-length ( dlist -- )
[ dlist-length 1- ] keep set-dlist-length ; inline
[ 1- ] change-length drop ; inline
: set-prev-when ( dlist-node dlist-node/f -- )
[ set-dlist-node-prev ] [ drop ] if* ;
[ (>>prev) ] [ drop ] if* ;
: set-next-when ( dlist-node dlist-node/f -- )
[ set-dlist-node-next ] [ drop ] if* ;
[ (>>next) ] [ drop ] if* ;
: set-next-prev ( dlist-node -- )
dup dlist-node-next set-prev-when ;
dup next>> set-prev-when ;
: normalize-front ( dlist -- )
dup dlist-back [ drop ] [ f swap set-dlist-front ] if ;
dup back>> [ f >>front ] unless drop ;
: normalize-back ( dlist -- )
dup dlist-front [ drop ] [ f swap set-dlist-back ] if ;
dup front>> [ f >>back ] unless drop ;
: set-back-to-front ( dlist -- )
dup dlist-back
[ drop ] [ dup dlist-front swap set-dlist-back ] if ;
dup back>> [ dup front>> >>back ] unless drop ;
: set-front-to-back ( dlist -- )
dup dlist-front
[ drop ] [ dup dlist-back swap set-dlist-front ] if ;
dup front>> [ dup back>> >>front ] unless drop ;
: (dlist-find-node) ( quot dlist-node -- node/f ? )
dup dlist-node-obj pick dupd call [
drop nip t
] [
drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if*
] if ; inline
: (dlist-find-node) ( dlist-node quot -- node/f ? )
over [
[ >r obj>> r> call ] 2keep rot
[ drop t ] [ >r next>> r> (dlist-find-node) ] if
] [ 2drop f f ] if ; inline
: dlist-find-node ( quot dlist -- node/f ? )
dlist-front [ (dlist-find-node) ] [ drop f f ] if* ; inline
: dlist-find-node ( dlist quot -- node/f ? )
>r front>> r> (dlist-find-node) ; inline
: (dlist-each-node) ( quot dlist -- )
over
[ 2dup call >r dlist-node-next r> (dlist-each-node) ]
[ 2drop ] if ; inline
: dlist-each-node ( dlist quot -- )
[ t ] compose dlist-find-node 2drop ; inline
: dlist-each-node ( quot dlist -- )
>r dlist-front r> (dlist-each-node) ; inline
PRIVATE>
: push-front* ( obj dlist -- dlist-node )
[ dlist-front f swap <dlist-node> dup dup set-next-prev ] keep
[ set-dlist-front ] keep
[ front>> f swap <dlist-node> dup dup set-next-prev ] keep
[ (>>front) ] keep
[ set-back-to-front ] keep
inc-length ;
@ -76,9 +72,9 @@ PRIVATE>
[ push-front ] curry each ;
: push-back* ( obj dlist -- dlist-node )
[ dlist-back f <dlist-node> ] keep
[ dlist-back set-next-when ] 2keep
[ set-dlist-back ] 2keep
[ back>> f <dlist-node> ] keep
[ back>> set-next-when ] 2keep
[ (>>back) ] 2keep
[ set-front-to-back ] keep
inc-length ;
@ -89,70 +85,75 @@ PRIVATE>
[ push-back ] curry each ;
: peek-front ( dlist -- obj )
dlist-front dlist-node-obj ;
front>> obj>> ;
: pop-front ( dlist -- obj )
dup dlist-front [
dup dlist-node-next
f rot set-dlist-node-next
dup front>> [
dup next>>
f rot (>>next)
f over set-prev-when
swap set-dlist-front
] 2keep dlist-node-obj
swap (>>front)
] 2keep obj>>
swap [ normalize-back ] keep dec-length ;
: pop-front* ( dlist -- ) pop-front drop ;
: peek-back ( dlist -- obj )
dlist-back dlist-node-obj ;
back>> obj>> ;
: pop-back ( dlist -- obj )
dup dlist-back [
dup dlist-node-prev
f rot set-dlist-node-prev
dup back>> [
dup prev>>
f rot (>>prev)
f over set-next-when
swap set-dlist-back
] 2keep dlist-node-obj
swap (>>back)
] 2keep obj>>
swap [ normalize-front ] keep dec-length ;
: pop-back* ( dlist -- ) pop-back drop ;
: dlist-find ( quot dlist -- obj/f ? )
dlist-find-node dup [ >r dlist-node-obj r> ] when ; inline
: dlist-find ( dlist quot -- obj/f ? )
dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
: dlist-contains? ( quot dlist -- ? )
: dlist-contains? ( dlist quot -- ? )
dlist-find nip ; inline
: unlink-node ( dlist-node -- )
dup dlist-node-prev over dlist-node-next set-prev-when
dup dlist-node-next swap dlist-node-prev set-next-when ;
dup prev>> over next>> set-prev-when
dup next>> swap prev>> set-next-when ;
: delete-node ( dlist dlist-node -- )
{
{ [ over dlist-front over eq? ] [ drop pop-front* ] }
{ [ over dlist-back over eq? ] [ drop pop-back* ] }
{ [ over front>> over eq? ] [ drop pop-front* ] }
{ [ over back>> over eq? ] [ drop pop-back* ] }
{ [ t ] [ unlink-node dec-length ] }
} cond ;
: delete-node-if* ( quot dlist -- obj/f ? )
tuck dlist-find-node [
[ delete-node ] keep [ dlist-node-obj t ] [ f f ] if*
: delete-node-if* ( dlist quot -- obj/f ? )
dupd dlist-find-node [
dup [
[ delete-node ] keep obj>> t
] [
2drop f f
] if
] [
2drop f f
] if ; inline
: delete-node-if ( quot dlist -- obj/f )
: delete-node-if ( dlist quot -- obj/f )
delete-node-if* drop ; inline
: dlist-delete ( obj dlist -- obj/f )
>r [ eq? ] curry r> delete-node-if ;
swap [ eq? ] curry delete-node-if ;
: dlist-delete-all ( dlist -- )
f over set-dlist-front
f over set-dlist-back
0 swap set-dlist-length ;
f >>front
f >>back
0 >>length
drop ;
: dlist-each ( dlist quot -- )
[ dlist-node-obj ] swap compose dlist-each-node ; inline
[ obj>> ] swap compose dlist-each-node ; inline
: dlist-slurp ( dlist quot -- )
over dlist-empty?
@ -160,4 +161,3 @@ PRIVATE>
inline
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;

4
extra/concurrency/mailboxes/mailboxes-docs.factor
View File

@ -49,8 +49,8 @@ HELP: while-mailbox-empty
{ $description "Repeatedly call the quotation while there are no items in the mailbox." } ;
HELP: mailbox-get?
{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
{ "mailbox" mailbox }
{ $values { "mailbox" mailbox }
{ "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
{ "obj" object }
}
{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ;

14
extra/concurrency/mailboxes/mailboxes-tests.factor
View File

@ -16,9 +16,9 @@ tools.test math kernel strings ;
[ V{ 1 2 3 } ] [
0 <vector>
<mailbox>
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
1 over mailbox-put
2 over mailbox-put
3 swap mailbox-put
@ -27,10 +27,10 @@ tools.test math kernel strings ;
[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
0 <vector>
<mailbox>
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ string? ] swap mailbox-get? swap push ] in-thread
[ [ string? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ string? ] mailbox-get? swap push ] in-thread
[ [ string? ] mailbox-get? swap push ] in-thread
1 over mailbox-put
"junk" over mailbox-put
[ 456 ] over mailbox-put

18
extra/concurrency/mailboxes/mailboxes.factor
View File

@ -17,17 +17,17 @@ TUPLE: mailbox threads data ;
[ mailbox-data push-front ] keep
mailbox-threads notify-all yield ;
: block-unless-pred ( pred mailbox timeout -- )
2over mailbox-data dlist-contains? [
: block-unless-pred ( mailbox timeout pred -- )
pick mailbox-data over dlist-contains? [
3drop
] [
2dup >r mailbox-threads r> "mailbox" wait
>r over mailbox-threads over "mailbox" wait r>
block-unless-pred
] if ; inline
: block-if-empty ( mailbox timeout -- mailbox )
over mailbox-empty? [
2dup >r mailbox-threads r> "mailbox" wait
over mailbox-threads over "mailbox" wait
block-if-empty
] [
drop
@ -58,12 +58,12 @@ TUPLE: mailbox threads data ;
2drop
] if ; inline
: mailbox-get-timeout? ( pred mailbox timeout -- obj )
[ block-unless-pred ] 3keep drop
mailbox-data delete-node-if ; inline
: mailbox-get-timeout? ( mailbox timeout pred -- obj )
3dup block-unless-pred
nip >r mailbox-data r> delete-node-if ; inline
: mailbox-get? ( pred mailbox -- obj )
f mailbox-get-timeout? ; inline
: mailbox-get? ( mailbox pred -- obj )
f swap mailbox-get-timeout? ; inline
TUPLE: linked-error thread ;

6
extra/concurrency/messaging/messaging.factor
View File

@ -26,10 +26,10 @@ M: thread send ( message thread -- )
my-mailbox swap mailbox-get-timeout ?linked ;
: receive-if ( pred -- message )
my-mailbox mailbox-get? ?linked ; inline
my-mailbox swap mailbox-get? ?linked ; inline
: receive-if-timeout ( pred timeout -- message )
my-mailbox swap mailbox-get-timeout? ?linked ; inline
: receive-if-timeout ( timeout pred -- message )
my-mailbox -rot mailbox-get-timeout? ?linked ; inline
: rethrow-linked ( error process supervisor -- )
>r <linked-error> r> send ;