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 } ; { $see-also push-front push-back pop-front pop-front* pop-back } ;
HELP: dlist-find 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." } { $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 } "." { $notes "Returns a boolean to allow dlists to store " { $link f } "."
$nl $nl
@ -93,20 +93,20 @@ HELP: dlist-find
} ; } ;
HELP: dlist-contains? 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." } { $description "Just like " { $link dlist-find } " except it doesn't return the object." }
{ $notes "This operation is O(n)." } ; { $notes "This operation is O(n)." } ;
HELP: delete-node-if* 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." } { $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)." } ; { $notes "This operation is O(n)." } ;
HELP: delete-node-if 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." } { $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)." } ; { $notes "This operation is O(n)." } ;
HELP: dlist-each 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." } ; { $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 dlist-front dlist-node-next dlist-node-next
] unit-test ] unit-test
[ f f ] [ <dlist> [ 1 = ] swap dlist-find ] unit-test [ f f ] [ <dlist> [ 1 = ] dlist-find ] unit-test
[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-find ] unit-test [ 1 t ] [ <dlist> 1 over push-back [ 1 = ] dlist-find ] unit-test
[ f f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-find ] unit-test [ f f ] [ <dlist> 1 over push-back [ 2 = ] dlist-find ] unit-test
[ f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test [ f ] [ <dlist> 1 over push-back [ 2 = ] dlist-contains? ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] swap 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 [ 1 ] [ <dlist> 1 over push-back [ 1 = ] 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 dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] over 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 [ 1 = ] over delete-node-if drop dlist-length ] 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 [ 1 = ] over 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 [ 1 = ] over 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 [ 2 = ] over 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 [ 3 = ] over 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 [ 0 ] [ <dlist> dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-front 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. ! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math sequences ; USING: combinators kernel math sequences accessors ;
IN: dlists IN: dlists
TUPLE: dlist front back length ; TUPLE: dlist front back length ;
: <dlist> ( -- obj ) : <dlist> ( -- obj )
dlist construct-empty dlist construct-empty
0 over set-dlist-length ; 0 >>length ;
: dlist-empty? ( dlist -- ? ) dlist-front not ; : dlist-empty? ( dlist -- ? ) front>> not ;
<PRIVATE <PRIVATE
TUPLE: dlist-node obj prev next ; TUPLE: dlist-node obj prev next ;
C: <dlist-node> dlist-node C: <dlist-node> dlist-node
: inc-length ( dlist -- ) : inc-length ( dlist -- )
[ dlist-length 1+ ] keep set-dlist-length ; inline [ 1+ ] change-length drop ; inline
: dec-length ( dlist -- ) : 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-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-next-when ( dlist-node dlist-node/f -- )
[ set-dlist-node-next ] [ drop ] if* ; [ (>>next) ] [ drop ] if* ;
: set-next-prev ( dlist-node -- ) : set-next-prev ( dlist-node -- )
dup dlist-node-next set-prev-when ; dup next>> set-prev-when ;
: normalize-front ( dlist -- ) : normalize-front ( dlist -- )
dup dlist-back [ drop ] [ f swap set-dlist-front ] if ; dup back>> [ f >>front ] unless drop ;
: normalize-back ( dlist -- ) : normalize-back ( dlist -- )
dup dlist-front [ drop ] [ f swap set-dlist-back ] if ; dup front>> [ f >>back ] unless drop ;
: set-back-to-front ( dlist -- ) : set-back-to-front ( dlist -- )
dup dlist-back dup back>> [ dup front>> >>back ] unless drop ;
[ drop ] [ dup dlist-front swap set-dlist-back ] if ;
: set-front-to-back ( dlist -- ) : set-front-to-back ( dlist -- )
dup dlist-front dup front>> [ dup back>> >>front ] unless drop ;
[ drop ] [ dup dlist-back swap set-dlist-front ] if ;
: (dlist-find-node) ( quot dlist-node -- node/f ? ) : (dlist-find-node) ( dlist-node quot -- node/f ? )
dup dlist-node-obj pick dupd call [ over [
drop nip t [ >r obj>> r> call ] 2keep rot
] [ [ drop t ] [ >r next>> r> (dlist-find-node) ] if
drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if* ] [ 2drop f f ] if ; inline
] if ; inline
: dlist-find-node ( quot dlist -- node/f ? ) : dlist-find-node ( dlist quot -- node/f ? )
dlist-front [ (dlist-find-node) ] [ drop f f ] if* ; inline >r front>> r> (dlist-find-node) ; inline
: (dlist-each-node) ( quot dlist -- ) : dlist-each-node ( dlist quot -- )
over [ t ] compose dlist-find-node 2drop ; inline
[ 2dup call >r dlist-node-next r> (dlist-each-node) ]
[ 2drop ] if ; inline
: dlist-each-node ( quot dlist -- )
>r dlist-front r> (dlist-each-node) ; inline
PRIVATE> PRIVATE>
: push-front* ( obj dlist -- dlist-node ) : push-front* ( obj dlist -- dlist-node )
[ dlist-front f swap <dlist-node> dup dup set-next-prev ] keep [ front>> f swap <dlist-node> dup dup set-next-prev ] keep
[ set-dlist-front ] keep [ (>>front) ] keep
[ set-back-to-front ] keep [ set-back-to-front ] keep
inc-length ; inc-length ;
@ -76,9 +72,9 @@ PRIVATE>
[ push-front ] curry each ; [ push-front ] curry each ;
: push-back* ( obj dlist -- dlist-node ) : push-back* ( obj dlist -- dlist-node )
[ dlist-back f <dlist-node> ] keep [ back>> f <dlist-node> ] keep
[ dlist-back set-next-when ] 2keep [ back>> set-next-when ] 2keep
[ set-dlist-back ] 2keep [ (>>back) ] 2keep
[ set-front-to-back ] keep [ set-front-to-back ] keep
inc-length ; inc-length ;
@ -89,70 +85,75 @@ PRIVATE>
[ push-back ] curry each ; [ push-back ] curry each ;
: peek-front ( dlist -- obj ) : peek-front ( dlist -- obj )
dlist-front dlist-node-obj ; front>> obj>> ;
: pop-front ( dlist -- obj ) : pop-front ( dlist -- obj )
dup dlist-front [ dup front>> [
dup dlist-node-next dup next>>
f rot set-dlist-node-next f rot (>>next)
f over set-prev-when f over set-prev-when
swap set-dlist-front swap (>>front)
] 2keep dlist-node-obj ] 2keep obj>>
swap [ normalize-back ] keep dec-length ; swap [ normalize-back ] keep dec-length ;
: pop-front* ( dlist -- ) pop-front drop ; : pop-front* ( dlist -- ) pop-front drop ;
: peek-back ( dlist -- obj ) : peek-back ( dlist -- obj )
dlist-back dlist-node-obj ; back>> obj>> ;
: pop-back ( dlist -- obj ) : pop-back ( dlist -- obj )
dup dlist-back [ dup back>> [
dup dlist-node-prev dup prev>>
f rot set-dlist-node-prev f rot (>>prev)
f over set-next-when f over set-next-when
swap set-dlist-back swap (>>back)
] 2keep dlist-node-obj ] 2keep obj>>
swap [ normalize-front ] keep dec-length ; swap [ normalize-front ] keep dec-length ;
: pop-back* ( dlist -- ) pop-back drop ; : pop-back* ( dlist -- ) pop-back drop ;
: dlist-find ( quot dlist -- obj/f ? ) : dlist-find ( dlist quot -- obj/f ? )
dlist-find-node dup [ >r dlist-node-obj r> ] when ; inline dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
: dlist-contains? ( quot dlist -- ? ) : dlist-contains? ( dlist quot -- ? )
dlist-find nip ; inline dlist-find nip ; inline
: unlink-node ( dlist-node -- ) : unlink-node ( dlist-node -- )
dup dlist-node-prev over dlist-node-next set-prev-when dup prev>> over next>> set-prev-when
dup dlist-node-next swap dlist-node-prev set-next-when ; dup next>> swap prev>> set-next-when ;
: delete-node ( dlist dlist-node -- ) : delete-node ( dlist dlist-node -- )
{ {
{ [ over dlist-front over eq? ] [ drop pop-front* ] } { [ over front>> over eq? ] [ drop pop-front* ] }
{ [ over dlist-back over eq? ] [ drop pop-back* ] } { [ over back>> over eq? ] [ drop pop-back* ] }
{ [ t ] [ unlink-node dec-length ] } { [ t ] [ unlink-node dec-length ] }
} cond ; } cond ;
: delete-node-if* ( quot dlist -- obj/f ? ) : delete-node-if* ( dlist quot -- obj/f ? )
tuck dlist-find-node [ dupd dlist-find-node [
[ delete-node ] keep [ dlist-node-obj t ] [ f f ] if* dup [
[ delete-node ] keep obj>> t
] [
2drop f f
] if
] [ ] [
2drop f f 2drop f f
] if ; inline ] if ; inline
: delete-node-if ( quot dlist -- obj/f ) : delete-node-if ( dlist quot -- obj/f )
delete-node-if* drop ; inline delete-node-if* drop ; inline
: dlist-delete ( obj dlist -- obj/f ) : dlist-delete ( obj dlist -- obj/f )
>r [ eq? ] curry r> delete-node-if ; swap [ eq? ] curry delete-node-if ;
: dlist-delete-all ( dlist -- ) : dlist-delete-all ( dlist -- )
f over set-dlist-front f >>front
f over set-dlist-back f >>back
0 swap set-dlist-length ; 0 >>length
drop ;
: dlist-each ( dlist quot -- ) : dlist-each ( dlist quot -- )
[ dlist-node-obj ] swap compose dlist-each-node ; inline [ obj>> ] swap compose dlist-each-node ; inline
: dlist-slurp ( dlist quot -- ) : dlist-slurp ( dlist quot -- )
over dlist-empty? over dlist-empty?
@ -160,4 +161,3 @@ PRIVATE>
inline inline
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ; : 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." } ; { $description "Repeatedly call the quotation while there are no items in the mailbox." } ;
HELP: mailbox-get? HELP: mailbox-get?
{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } { $values { "mailbox" mailbox }
{ "mailbox" mailbox } { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
{ "obj" object } { "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." } ; { $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 } ] [ [ V{ 1 2 3 } ] [
0 <vector> 0 <vector>
<mailbox> <mailbox>
[ [ integer? ] swap mailbox-get? swap push ] in-thread [ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread [ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread [ [ integer? ] mailbox-get? swap push ] in-thread
1 over mailbox-put 1 over mailbox-put
2 over mailbox-put 2 over mailbox-put
3 swap mailbox-put 3 swap mailbox-put
@ -27,10 +27,10 @@ tools.test math kernel strings ;
[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [ [ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
0 <vector> 0 <vector>
<mailbox> <mailbox>
[ [ integer? ] swap mailbox-get? swap push ] in-thread [ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread [ [ integer? ] mailbox-get? swap push ] in-thread
[ [ string? ] swap mailbox-get? swap push ] in-thread [ [ string? ] mailbox-get? swap push ] in-thread
[ [ string? ] swap mailbox-get? swap push ] in-thread [ [ string? ] mailbox-get? swap push ] in-thread
1 over mailbox-put 1 over mailbox-put
"junk" over mailbox-put "junk" over mailbox-put
[ 456 ] 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-data push-front ] keep
mailbox-threads notify-all yield ; mailbox-threads notify-all yield ;
: block-unless-pred ( pred mailbox timeout -- ) : block-unless-pred ( mailbox timeout pred -- )
2over mailbox-data dlist-contains? [ pick mailbox-data over dlist-contains? [
3drop 3drop
] [ ] [
2dup >r mailbox-threads r> "mailbox" wait >r over mailbox-threads over "mailbox" wait r>
block-unless-pred block-unless-pred
] if ; inline ] if ; inline
: block-if-empty ( mailbox timeout -- mailbox ) : block-if-empty ( mailbox timeout -- mailbox )
over mailbox-empty? [ over mailbox-empty? [
2dup >r mailbox-threads r> "mailbox" wait over mailbox-threads over "mailbox" wait
block-if-empty block-if-empty
] [ ] [
drop drop
@ -58,12 +58,12 @@ TUPLE: mailbox threads data ;
2drop 2drop
] if ; inline ] if ; inline
: mailbox-get-timeout? ( pred mailbox timeout -- obj ) : mailbox-get-timeout? ( mailbox timeout pred -- obj )
[ block-unless-pred ] 3keep drop 3dup block-unless-pred
mailbox-data delete-node-if ; inline nip >r mailbox-data r> delete-node-if ; inline
: mailbox-get? ( pred mailbox -- obj ) : mailbox-get? ( mailbox pred -- obj )
f mailbox-get-timeout? ; inline f swap mailbox-get-timeout? ; inline
TUPLE: linked-error thread ; 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 ; my-mailbox swap mailbox-get-timeout ?linked ;
: receive-if ( pred -- message ) : receive-if ( pred -- message )
my-mailbox mailbox-get? ?linked ; inline my-mailbox swap mailbox-get? ?linked ; inline
: receive-if-timeout ( pred timeout -- message ) : receive-if-timeout ( timeout pred -- message )
my-mailbox swap mailbox-get-timeout? ?linked ; inline my-mailbox -rot mailbox-get-timeout? ?linked ; inline
: rethrow-linked ( error process supervisor -- ) : rethrow-linked ( error process supervisor -- )
>r <linked-error> r> send ; >r <linked-error> r> send ;