diff --git a/core/dlists/dlists-docs.factor b/core/dlists/dlists-docs.factor index 2aeaadad3e..c957c04453 100755 --- a/core/dlists/dlists-docs.factor +++ b/core/dlists/dlists-docs.factor @@ -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." } ; diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor index cd651bff2f..2bc0e6a3fb 100755 --- a/core/dlists/dlists-tests.factor +++ b/core/dlists/dlists-tests.factor @@ -43,20 +43,20 @@ IN: dlists.tests dlist-front dlist-node-next dlist-node-next ] unit-test -[ f f ] [ [ 1 = ] swap dlist-find ] unit-test -[ 1 t ] [ 1 over push-back [ 1 = ] swap dlist-find ] unit-test -[ f f ] [ 1 over push-back [ 2 = ] swap dlist-find ] unit-test -[ f ] [ 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test -[ t ] [ 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test +[ f f ] [ [ 1 = ] dlist-find ] unit-test +[ 1 t ] [ 1 over push-back [ 1 = ] dlist-find ] unit-test +[ f f ] [ 1 over push-back [ 2 = ] dlist-find ] unit-test +[ f ] [ 1 over push-back [ 2 = ] dlist-contains? ] unit-test +[ t ] [ 1 over push-back [ 1 = ] dlist-contains? ] unit-test -[ 1 ] [ 1 over push-back [ 1 = ] swap delete-node-if ] unit-test -[ t ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test -[ t ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test -[ 0 ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test -[ 1 ] [ 1 over push-back 2 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node-if drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node-if drop dlist-length ] unit-test +[ 1 ] [ 1 over push-back [ 1 = ] delete-node-if ] unit-test +[ t ] [ 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test +[ t ] [ 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test +[ 0 ] [ 1 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test +[ 1 ] [ 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop dlist-length ] unit-test [ 0 ] [ dlist-length ] unit-test [ 1 ] [ 1 over push-front dlist-length ] unit-test diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index 38c4ee233e..56134f3b54 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -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 ; : ( -- obj ) dlist construct-empty - 0 over set-dlist-length ; + 0 >>length ; -: dlist-empty? ( dlist -- ? ) dlist-front not ; +: dlist-empty? ( dlist -- ? ) front>> not ; 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 dup dup set-next-prev ] keep - [ set-dlist-front ] keep + [ front>> f swap 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 ] keep - [ dlist-back set-next-when ] 2keep - [ set-dlist-back ] 2keep + [ back>> f ] 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 ) [ push-front ] keep ; - diff --git a/extra/concurrency/mailboxes/mailboxes-docs.factor b/extra/concurrency/mailboxes/mailboxes-docs.factor index 4937ef1fb9..50694776c5 100755 --- a/extra/concurrency/mailboxes/mailboxes-docs.factor +++ b/extra/concurrency/mailboxes/mailboxes-docs.factor @@ -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." } ; diff --git a/extra/concurrency/mailboxes/mailboxes-tests.factor b/extra/concurrency/mailboxes/mailboxes-tests.factor index 24d83b2961..2cb12bcaba 100755 --- a/extra/concurrency/mailboxes/mailboxes-tests.factor +++ b/extra/concurrency/mailboxes/mailboxes-tests.factor @@ -16,9 +16,9 @@ tools.test math kernel strings ; [ V{ 1 2 3 } ] [ 0 - [ [ 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 - [ [ 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 diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index 28b2fb7221..7b6405679f 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -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 ; diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor index e566a83fdf..2cd83d43f5 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/extra/concurrency/messaging/messaging.factor @@ -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 r> send ;