diff --git a/Makefile b/Makefile index a67f24f19d..77a6fb6409 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,6 @@ CC = gcc +AR = ar +LD = ld EXECUTABLE = factor VERSION = 0.91 diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index f6f3e5c0da..4204503372 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -442,7 +442,7 @@ M: curry ' PRIVATE> -: make-image ( architecture -- ) +: make-image ( arch -- ) [ parse-hook off prepare-image @@ -452,6 +452,9 @@ PRIVATE> image get image-name write-image ] with-scope ; +: my-arch ( -- arch ) + cpu dup "ppc" = [ os "-" rot 3append ] when ; + : make-images ( -- ) { "x86.32" "x86.64" "linux-ppc" "macosx-ppc" "arm" diff --git a/extra/dlists/authors.txt b/core/dlists/authors.txt similarity index 59% rename from extra/dlists/authors.txt rename to core/dlists/authors.txt index 09839c9c91..ebeb56efd2 100644 --- a/extra/dlists/authors.txt +++ b/core/dlists/authors.txt @@ -1 +1,2 @@ Mackenzie Straight +Doug Coleman diff --git a/core/dlists/dlists-docs.factor b/core/dlists/dlists-docs.factor new file mode 100644 index 0000000000..5a808a9a5d --- /dev/null +++ b/core/dlists/dlists-docs.factor @@ -0,0 +1,104 @@ +USING: help.markup help.syntax kernel ; +IN: dlists + +ARTICLE: "dlists" "Doubly-linked lists" +"A doubly-linked list, or dlist, is a list of nodes. Each node has a link to the previous and next nodes, and a slot to store an object." +$nl +"While nodes can be modified directly, the fundamental protocol support by doubly-linked lists is that of a double-ended queue with a few additional operations. Elements can be added or removed at both ends of the dlist in constant time." +$nl +"When using a dlist as a simple queue, the convention is to queue elements with " { $link push-front } " and dequeue them with " { $link pop-back } "." +$nl +"Dlists form a class:" +{ $subsection dlist } +{ $subsection dlist? } +"Constructing a dlist:" +{ $subsection } +"Double-ended queue protocol:" +{ $subsection dlist-empty? } +{ $subsection push-front } +{ $subsection pop-front } +{ $subsection pop-front* } +{ $subsection push-back } +{ $subsection pop-back } +{ $subsection pop-back* } +"Finding out the length:" +{ $subsection dlist-length } +"Iterating over elements:" +{ $subsection dlist-each } +{ $subsection dlist-find } +{ $subsection dlist-contains? } +"Deleting a node matching a predicate:" +{ $subsection delete-node* } +{ $subsection delete-node } +"Consuming all nodes:" +{ $subsection dlist-slurp } ; + +ABOUT: "dlists" + +HELP: dlist-empty? +{ $values { "dlist" { $link dlist } } { "?" "a boolean" } } +{ $description "Returns true if a " { $link dlist } " is empty." } +{ $notes "This operation is O(1)." } ; + +HELP: push-front +{ $values { "obj" "an object" } { "dlist" dlist } } +{ $description "Push the object onto the front of the " { $link dlist } "." } +{ $notes "This operation is O(1)." } +{ $see-also push-back pop-front pop-front* pop-back pop-back* } ; + +HELP: push-back +{ $values { "obj" "an object" } { "dlist" dlist } } +{ $description "Push the object onto the back of the " { $link dlist } "." } +{ $notes "This operation is O(1)." } +{ $see-also push-front pop-front pop-front* pop-back pop-back* } ; + +HELP: pop-front +{ $values { "dlist" dlist } { "obj" "an object" } } +{ $description "Pop the object off the front of the " { $link dlist } " and return the object." } +{ $notes "This operation is O(1)." } +{ $see-also push-front push-back pop-front* pop-back pop-back* } ; + +HELP: pop-front* +{ $values { "dlist" dlist } } +{ $description "Pop the object off the front of the " { $link dlist } "." } +{ $notes "This operation is O(1)." } +{ $see-also push-front push-back pop-front pop-back pop-back* } ; + +HELP: pop-back +{ $values { "dlist" dlist } { "obj" "an object" } } +{ $description "Pop the object off the back of the " { $link dlist } " and return the object." } +{ $notes "This operation is O(1)." } +{ $see-also push-front push-back pop-front pop-front* pop-back* } ; + +HELP: pop-back* +{ $values { "dlist" dlist } } +{ $description "Pop the object off the back of the " { $link dlist } "." } +{ $notes "This operation is O(1)." } +{ $see-also push-front push-back pop-front pop-front* pop-back } ; + +HELP: dlist-find +{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "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 + "This operation is O(n)." +} ; + +HELP: dlist-contains? +{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "?" "a boolean" } } +{ $description "Just like " { $link dlist-find } " except it doesn't return the object." } +{ $notes "This operation is O(n)." } ; + +HELP: delete-node* +{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "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 +{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } } +{ $description "Like " { $link delete-node* } " 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" "a quotation" } { "dlist" { $link dlist } } } +{ $description "Iterate a " { $link dlist } ", calling quot on each element." } ; diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor new file mode 100644 index 0000000000..f4482d680d --- /dev/null +++ b/core/dlists/dlists-tests.factor @@ -0,0 +1,61 @@ +USING: dlists dlists.private kernel tools.test ; +IN: temporary + +[ t ] [ dlist-empty? ] unit-test + +[ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } 1 } ] +[ 1 over push-front ] unit-test + +! Make sure empty lists are empty +[ t ] [ dlist-empty? ] unit-test +[ f ] [ 1 over push-front dlist-empty? ] unit-test +[ f ] [ 1 over push-back dlist-empty? ] unit-test + +[ 1 ] [ 1 over push-front pop-front ] unit-test +[ 1 ] [ 1 over push-front pop-back ] unit-test +[ 1 ] [ 1 over push-back pop-front ] unit-test +[ 1 ] [ 1 over push-back pop-back ] unit-test +[ T{ dlist f f f 0 } ] [ 1 over push-front dup pop-front* ] unit-test +[ T{ dlist f f f 0 } ] [ 1 over push-front dup pop-back* ] unit-test +[ T{ dlist f f f 0 } ] [ 1 over push-back dup pop-front* ] unit-test +[ T{ dlist f f f 0 } ] [ 1 over push-back dup pop-back* ] unit-test + +! Test the prev,next links for two nodes +[ f ] [ + 1 over push-back 2 over push-back + dlist-front dlist-node-prev +] unit-test + +[ 2 ] [ + 1 over push-back 2 over push-back + dlist-front dlist-node-next dlist-node-obj +] unit-test + +[ 1 ] [ + 1 over push-back 2 over push-back + dlist-front dlist-node-next dlist-node-prev dlist-node-obj +] unit-test + +[ f ] [ + 1 over push-back 2 over push-back + 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 + +[ 1 ] [ 1 over push-back [ 1 = ] swap delete-node ] unit-test +[ t ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test +[ t ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test +[ 0 ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test +[ 1 ] [ 1 over push-back 2 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node drop dlist-length ] unit-test + +[ 0 ] [ dlist-length ] unit-test +[ 1 ] [ 1 over push-front dlist-length ] unit-test +[ 0 ] [ 1 over push-front dup pop-front* dlist-length ] unit-test diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor new file mode 100644 index 0000000000..890185d4c4 --- /dev/null +++ b/core/dlists/dlists.factor @@ -0,0 +1,130 @@ +! Copyright (C) 2007 Mackenzie Straight, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators kernel math ; +IN: dlists + +TUPLE: dlist front back length ; + +: ( -- obj ) + dlist construct-empty + 0 over set-dlist-length ; + +: dlist-empty? ( dlist -- ? ) dlist-front not ; + + dlist-node + +: inc-length ( dlist -- ) + [ dlist-length 1+ ] keep set-dlist-length ; inline + +: dec-length ( dlist -- ) + [ dlist-length 1- ] keep set-dlist-length ; inline + +: set-prev-when ( dlist-node dlist-node/f -- ) + [ set-dlist-node-prev ] [ drop ] if* ; + +: set-next-when ( dlist-node dlist-node/f -- ) + [ set-dlist-node-next ] [ drop ] if* ; + +: set-next-prev ( dlist-node -- ) + dup dlist-node-next set-prev-when ; + +: normalize-front ( dlist -- ) + dup dlist-back [ drop ] [ f swap set-dlist-front ] if ; + +: normalize-back ( dlist -- ) + dup dlist-front [ drop ] [ f swap set-dlist-back ] if ; + +: set-back-to-front ( dlist -- ) + dup dlist-back + [ drop ] [ dup dlist-front swap set-dlist-back ] if ; + +: set-front-to-back ( dlist -- ) + dup dlist-front + [ drop ] [ dup dlist-back swap set-dlist-front ] if ; + +: (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 ; + +: dlist-find-node ( quot dlist -- node/f ? ) + dlist-front [ (dlist-find-node) ] [ drop f f ] if* ; + +: (dlist-each-node) ( quot dlist -- ) + over + [ 2dup call >r dlist-node-next r> (dlist-each-node) ] + [ 2drop ] if ; + +: dlist-each-node ( quot dlist -- ) + >r dlist-front r> (dlist-each-node) ; inline +PRIVATE> + +: push-front ( obj dlist -- ) + [ dlist-front f swap dup set-next-prev ] keep + [ set-dlist-front ] keep + [ set-back-to-front ] keep + inc-length ; + +: push-back ( obj dlist -- ) + [ dlist-back f ] keep + [ dlist-back set-next-when ] 2keep + [ set-dlist-back ] keep + [ set-front-to-back ] keep + inc-length ; + +: pop-front ( dlist -- obj ) + dup dlist-front [ + dlist-node-next + f over set-prev-when + swap set-dlist-front + ] 2keep dlist-node-obj + swap [ normalize-back ] keep dec-length ; + +: pop-front* ( dlist -- ) pop-front drop ; + +: pop-back ( dlist -- obj ) + [ + dlist-back dup dlist-node-prev f over set-next-when + ] keep + [ set-dlist-back ] keep + [ normalize-front ] keep + dec-length + dlist-node-obj ; + +: pop-back* ( dlist -- ) pop-back drop ; + +: dlist-find ( quot dlist -- obj/f ? ) + dlist-find-node dup [ >r dlist-node-obj r> ] when ; + +: dlist-contains? ( quot dlist -- ? ) + dlist-find nip ; + +: (delete-node) ( dlist dlist-node -- ) + { + { [ 2dup >r dlist-front r> = ] [ drop pop-front* ] } + { [ 2dup >r dlist-back r> = ] [ drop pop-back* ] } + { [ t ] [ dup dlist-node-prev swap dlist-node-next set-prev-when + dec-length ] } + } cond ; + +: delete-node* ( quot dlist -- obj/f ? ) + tuck dlist-find-node [ + [ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if* + ] [ + 2drop f f + ] if ; + +: delete-node ( quot dlist -- obj/f ) + delete-node* drop ; + +: dlist-each ( dlist quot -- ) + [ dlist-node-obj ] swap compose dlist-each-node ; inline + +: dlist-slurp ( dlist quot -- ) + over dlist-empty? + [ 2drop ] [ [ >r pop-back r> call ] 2keep dlist-slurp ] if ; + inline diff --git a/extra/dlists/summary.txt b/core/dlists/summary.txt similarity index 100% rename from extra/dlists/summary.txt rename to core/dlists/summary.txt diff --git a/core/queues/tags.txt b/core/dlists/tags.txt similarity index 100% rename from core/queues/tags.txt rename to core/dlists/tags.txt diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor new file mode 100644 index 0000000000..3605ec519a --- /dev/null +++ b/core/heaps/heaps-docs.factor @@ -0,0 +1,79 @@ +USING: heaps.private help.markup help.syntax kernel math assocs ; +IN: heaps + +ARTICLE: "heaps" "Heaps" +"A heap is an implementation of a " { $emphasis "priority queue" } ", which is a structure that maintains a sorted set of elements. The key property is that insertion of an arbitrary element and removal of the first element (determined by order) is performed in O(log n) time." +$nl +"Heap elements are key/value pairs and are compared using the " { $link <=> } " generic word on the first element of the pair." +$nl +"There are two classes of heaps. Min-heaps sort their elements so that the minimum element is first:" +{ $subsection min-heap } +{ $subsection min-heap? } +{ $subsection } +"Max-heaps sort their elements so that the maximum element is first:" +{ $subsection min-heap } +{ $subsection min-heap? } +{ $subsection } +"Both obey a protocol." +$nl +"Queries:" +{ $subsection heap-empty? } +{ $subsection heap-length } +{ $subsection heap-peek } +"Insertion:" +{ $subsection heap-push } +{ $subsection heap-push-all } +"Removal:" +{ $subsection heap-pop* } +{ $subsection heap-pop } ; + +ABOUT: "heaps" + +HELP: +{ $values { "min-heap" min-heap } } +{ $description "Create a new " { $link min-heap } "." } +{ $see-also } ; + +HELP: +{ $values { "max-heap" max-heap } } +{ $description "Create a new " { $link max-heap } "." } +{ $see-also } ; + +HELP: heap-push +{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } } +{ $description "Push an pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." } +{ $side-effects "heap" } +{ $see-also heap-push-all heap-pop } ; + +HELP: heap-push-all +{ $values { "assoc" assoc } { "heap" heap } } +{ $description "Push every key/value pair of an assoc onto a heap." } +{ $side-effects "heap" } +{ $see-also heap-push heap-pop } ; + +HELP: heap-peek +{ $values { "heap" heap } { "key" object } { "value" object } } +{ $description "Outputs the first element in the heap, leaving it in the heap." } +{ $see-also heap-pop heap-pop* } ; + +HELP: heap-pop* +{ $values { "heap" heap } } +{ $description "Removes the first element from the heap." } +{ $side-effects "heap" } +{ $see-also heap-pop heap-push heap-peek } ; + +HELP: heap-pop +{ $values { "heap" heap } { "key" object } { "value" object } } +{ $description "Outputs the first element in the heap and removes it from the heap." } +{ $side-effects "heap" } +{ $see-also heap-pop* heap-push heap-peek } ; + +HELP: heap-empty? +{ $values { "heap" heap } { "?" "a boolean" } } +{ $description "Tests if a " { $link heap } " has no nodes." } +{ $see-also heap-length heap-peek } ; + +HELP: heap-length +{ $values { "heap" heap } { "n" integer } } +{ $description "Returns the number of key/value pairs in the heap." } +{ $see-also heap-empty? } ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index a8087916e7..03e0816c19 100644 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -4,29 +4,32 @@ USING: kernel math tools.test heaps heaps.private ; IN: temporary -[ pop-heap ] unit-test-fails -[ pop-heap ] unit-test-fails +[ heap-pop ] unit-test-fails +[ heap-pop ] unit-test-fails [ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over push-heap heap-empty? ] unit-test +[ f ] [ 1 t pick heap-push heap-empty? ] unit-test [ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over push-heap heap-empty? ] unit-test +[ f ] [ 1 t pick heap-push heap-empty? ] unit-test ! Binary Min Heap { 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test -{ t } [ 5 3 T{ min-heap } heap-compare ] unit-test -{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test +{ t } [ { 5 t } { 3 t } T{ min-heap } heap-compare ] unit-test +{ f } [ { 5 t } { 3 t } T{ max-heap } heap-compare ] unit-test -[ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ] -[ { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over push-heap* ] unit-test +[ T{ min-heap T{ heap f V{ { -6 t } { -4 t } { 2 t } { 1 t } { 5 t } { 3 t } { 2 t } { 4 t } { 3 t } { 7 t } { 6 t } { 8 t } { 3 t } { 4 t } { 4 t } { 6 t } { 5 t } { 5 t } } } } ] +[ { { 3 t } { 5 t } { 4 t } { 6 t } { 7 t } { 8 t } { 2 t } { 4 t } { 3 t } { 5 t } { 6 t } { 1 t } { 3 t } { 2 t } { 4 t } { 5 t } { -6 t } { -4 t } } over heap-push-all ] unit-test -[ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [ - { 3 5 4 6 5 7 6 8 } over push-heap* - 3 [ dup pop-heap* ] times +[ T{ min-heap T{ heap f V{ { 5 t } { 6 t } { 6 t } { 7 t } { 8 t } } } } ] [ + { { 3 t } { 5 t } { 4 t } { 6 t } { 5 t } { 7 t } { 6 t } { 8 t } } over heap-push-all + 3 [ dup heap-pop* ] times ] unit-test -[ 2 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap pop-heap ] unit-test +[ t 2 ] [ t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push heap-pop ] unit-test -[ 1 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test +[ t 1 ] [ t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test -[ 400 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test +[ t 400 ] [ t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test + +[ 0 ] [ heap-length ] unit-test +[ 1 ] [ t 1 pick heap-push heap-length ] unit-test diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index 2ff9096483..73a37660f6 100644 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -1,83 +1,80 @@ ! Copyright (C) 2007 Ryan Murphy, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences ; +USING: kernel math sequences arrays assocs ; IN: heaps ( -- obj ) - V{ } clone heap construct-boa ; +: ( class -- heap ) + >r V{ } clone heap construct-boa r> + construct-delegate ; inline PRIVATE> TUPLE: min-heap ; -: ( -- obj ) - min-heap construct-delegate ; +: ( -- min-heap ) min-heap ; TUPLE: max-heap ; -: ( -- obj ) - max-heap construct-delegate ; +: ( -- max-heap ) max-heap ; r left r> nth ; -: right-value ( n heap -- obj ) >r right r> nth ; -: up-value ( n vec -- obj ) >r up r> nth ; -: swap-up ( n vec -- ) >r dup up r> exchange ; -: last-index ( vec -- n ) length 1- ; +: left ( n -- m ) 2 * 1+ ; inline +: right ( n -- m ) 2 * 2 + ; inline +: up ( n -- m ) 1- 2 /i ; inline +: left-value ( n heap -- obj ) >r left r> nth ; inline +: right-value ( n heap -- obj ) >r right r> nth ; inline +: up-value ( n vec -- obj ) >r up r> nth ; inline +: swap-up ( n vec -- ) >r dup up r> exchange ; inline +: last-index ( vec -- n ) length 1- ; inline -GENERIC: heap-compare ( obj1 obj2 heap -- ? ) +GENERIC: heap-compare ( pair1 pair2 heap -- ? ) +: (heap-compare) drop [ first ] compare 0 ; inline +M: min-heap heap-compare (heap-compare) > ; +M: max-heap heap-compare (heap-compare) < ; -M: min-heap heap-compare drop <=> 0 > ; -M: max-heap heap-compare drop <=> 0 < ; +: heap-bounds-check? ( m heap -- ? ) + heap-data length >= ; inline : left-bounds-check? ( m heap -- ? ) - >r left r> heap-data length >= ; + >r left r> heap-bounds-check? ; inline : right-bounds-check? ( m heap -- ? ) - >r right r> heap-data length >= ; + >r right r> heap-bounds-check? ; inline -: (up-heap) ( vec heap -- ) - [ - >r [ last-index ] keep [ up-value ] keep peek r> heap-compare - ] 2keep rot [ - >r dup last-index - [ over swap-up ] keep - up 1+ head-slice - r> (up-heap) +: up-heap-continue? ( vec heap -- ? ) + >r [ last-index ] keep [ up-value ] keep peek r> + heap-compare ; inline + +: up-heap ( vec heap -- ) + 2dup up-heap-continue? [ + >r dup last-index [ over swap-up ] keep + up 1+ head-slice r> up-heap ] [ 2drop ] if ; -: up-heap ( heap -- ) - [ heap-data ] keep (up-heap) ; +: (child) ( m heap -- n ) + dupd + [ heap-data left-value ] 2keep + [ heap-data right-value ] keep heap-compare + [ right ] [ left ] if ; : child ( m heap -- n ) - 2dup right-bounds-check? [ - drop left - ] [ - dupd - [ heap-data left-value ] 2keep - [ heap-data right-value ] keep heap-compare [ - right - ] [ - left - ] if - ] if ; + 2dup right-bounds-check? [ drop left ] [ (child) ] if ; : swap-down ( m heap -- ) [ child ] 2keep heap-data exchange ; DEFER: down-heap +: down-heap-continue? ( heap m heap -- m heap ? ) + [ heap-data nth ] 2keep child pick + dupd [ heap-data nth swapd ] keep heap-compare ; + : (down-heap) ( m heap -- ) - 2dup [ heap-data nth ] 2keep child pick - dupd [ heap-data nth swapd ] keep - heap-compare [ + 2dup down-heap-continue? [ -rot [ swap-down ] keep down-heap ] [ 3drop @@ -88,25 +85,29 @@ DEFER: down-heap PRIVATE> -: push-heap ( obj heap -- ) - tuck heap-data push up-heap ; +: heap-push ( value key heap -- ) + >r swap 2array r> + [ heap-data push ] keep + [ heap-data ] keep + up-heap ; -: push-heap* ( seq heap -- ) - swap [ swap push-heap ] curry* each ; +: heap-push-all ( assoc heap -- ) + [ swapd heap-push ] curry assoc-each ; -: peek-heap ( heap -- obj ) - heap-data first ; +: heap-peek ( heap -- value key ) + heap-data first first2 swap ; -: pop-heap* ( heap -- ) +: heap-pop* ( heap -- ) dup heap-data length 1 > [ - [ heap-data pop 0 ] keep - [ heap-data set-nth ] keep - >r 0 r> down-heap + [ heap-data pop ] keep + [ heap-data set-first ] keep + 0 swap down-heap ] [ heap-data pop* ] if ; -: pop-heap ( heap -- fist ) [ heap-data first ] keep pop-heap* ; +: heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ; -: heap-empty? ( heap -- ? ) - heap-data empty? ; +: heap-empty? ( heap -- ? ) heap-data empty? ; + +: heap-length ( heap -- n ) heap-data length ; diff --git a/core/none/deploy.factor b/core/none/deploy.factor new file mode 100644 index 0000000000..f604beab3f --- /dev/null +++ b/core/none/deploy.factor @@ -0,0 +1,13 @@ +USING: tools.deploy.config ; +H{ + { deploy-math? f } + { deploy-word-defs? f } + { deploy-word-props? f } + { deploy-name "none" } + { "stop-after-last-window?" t } + { deploy-c-types? f } + { deploy-compiler? f } + { deploy-io 1 } + { deploy-ui? f } + { deploy-reflection 1 } +} diff --git a/core/queues/authors.txt b/core/queues/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/core/queues/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/core/queues/queues-docs.factor b/core/queues/queues-docs.factor deleted file mode 100644 index 845b95ea1f..0000000000 --- a/core/queues/queues-docs.factor +++ /dev/null @@ -1,77 +0,0 @@ -USING: help.markup help.syntax kernel ; -IN: queues - -ARTICLE: "queues" "Queues" -"Last-in-first-out queues are defined in the " { $vocab-link "queues" } " vocabulary." -$nl -"Queues are a class." -{ $subsection queue } -{ $subsection queue? } -{ $subsection } -"Testing queues:" -{ $subsection queue-empty? } -"Adding elements:" -{ $subsection deque } -"Removing elements:" -{ $subsection enque } -{ $subsection clear-queue } -{ $subsection queue-each } -"An example:" -{ $code - " \"q\" set" - "5 \"q\" get enque" - "3 \"q\" get enque" - "7 \"q\" get enque" - "\"q\" get deque ." - " 5" - "\"q\" get deque ." - " 3" - "\"q\" get deque ." - " 7" -} ; - -ABOUT: "queues" - -HELP: queue -{ $class-description "A simple first-in-first-out queue. See " { $link "queues" } "." } ; - -HELP: entry -{ $class-description "The class of entries in a " { $link queue } ". Each entry holds an object and a reference to the next entry." } ; - -HELP: -{ $values { "obj" object } { "entry" entry } } -{ $description "Creates a new queue entry." } -{ $notes "This word is a factor of " { $link enque } "." } ; - -HELP: -{ $values { "queue" queue } } -{ $description "Makes a new queue with no elements." } ; - -HELP: queue-empty? -{ $values { "queue" queue } { "?" "a boolean" } } -{ $description "Tests if a queue contains no elements." } ; - -HELP: deque -{ $values { "queue" queue } { "elt" object } } -{ $description "Removes an element from the front of the queue." } -{ $errors "Throws an " { $link empty-queue-error } " if the queue has no entries." } -{ $side-effects "queue" } ; - -HELP: enque -{ $values { "elt" object } { "queue" queue } } -{ $description "Adds an element to the back of the queue." } -{ $side-effects "queue" } ; - -HELP: empty-queue-error -{ $description "Throws an " { $link empty-queue-error } "." } -{ $error-description "Thrown by " { $link deque } " if the queue has no entries." } ; - -HELP: clear-queue -{ $values { "queue" queue } } -{ $description "Removes all entries from the queue." } -{ $side-effects "queue" } ; - -HELP: queue-each -{ $values { "queue" queue } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } } -{ $description "Applies the quotation to each entry in the queue, starting from the least recently added entry, clearing the queue in the process." } -{ $side-effects "queue" } ; diff --git a/core/queues/queues-tests.factor b/core/queues/queues-tests.factor deleted file mode 100644 index d8df256fc0..0000000000 --- a/core/queues/queues-tests.factor +++ /dev/null @@ -1,12 +0,0 @@ -USING: kernel math namespaces queues sequences tools.test ; -IN: temporary - - "queue" set - -[ t ] [ "queue" get queue-empty? ] unit-test - -[ ] [ [ 1 2 3 4 5 ] [ "queue" get enque ] each ] unit-test - -[ { 1 2 3 4 5 } ] [ 5 [ drop "queue" get deque ] map ] unit-test - -[ "queue" get deque ] unit-test-fails diff --git a/core/queues/queues.factor b/core/queues/queues.factor deleted file mode 100644 index 0cd05ea8c0..0000000000 --- a/core/queues/queues.factor +++ /dev/null @@ -1,57 +0,0 @@ -! Copyright (C) 2005, 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -IN: queues -USING: kernel inspector ; - -TUPLE: entry obj next ; - -: ( obj -- entry ) f entry construct-boa ; - -TUPLE: queue head tail ; - -: ( -- queue ) queue construct-empty ; - -: queue-empty? ( queue -- ? ) queue-head not ; - -: (enque) ( entry queue -- ) - [ set-queue-head ] 2keep set-queue-tail ; - -: clear-queue ( queue -- ) - f swap (enque) ; - -: enque ( elt queue -- ) - >r r> dup queue-empty? [ - (enque) - ] [ - [ queue-tail set-entry-next ] 2keep set-queue-tail - ] if ; - -: clear-entry ( entry -- ) - f over set-entry-obj f swap set-entry-next ; - -: (deque) ( queue -- ) - dup queue-head over queue-tail eq? [ - clear-queue - ] [ - dup queue-head dup entry-next rot set-queue-head - clear-entry - ] if ; - -TUPLE: empty-queue-error ; -: empty-queue-error ( -- * ) - \ empty-queue-error construct-empty throw ; - -: deque ( queue -- elt ) - dup queue-empty? [ - empty-queue-error - ] [ - dup queue-head entry-obj >r (deque) r> - ] if ; - -M: empty-queue-error summary - drop "Empty queue" ; - -: queue-each ( queue quot -- ) - over queue-empty? - [ 2drop ] [ [ >r deque r> call ] 2keep queue-each ] if ; - inline diff --git a/core/queues/summary.txt b/core/queues/summary.txt deleted file mode 100644 index 7bc2a8c7f2..0000000000 --- a/core/queues/summary.txt +++ /dev/null @@ -1 +0,0 @@ -FIFO queues diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor index b4a7c340ad..181979bfed 100644 --- a/core/threads/threads-docs.factor +++ b/core/threads/threads-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax kernel kernel.private io -threads.private continuations queues ; +threads.private continuations dlists ; IN: threads ARTICLE: "threads" "Threads" @@ -20,8 +20,8 @@ $nl ABOUT: "threads" HELP: run-queue -{ $values { "queue" queue } } -{ $description "Outputs the runnable thread queue." } ; +{ $values { "queue" dlist } } +{ $description "Outputs the runnable thread queue. By convention, continuations are queued with " { $link push-front } " and dequeued with " { $link pop-back } "." } ; HELP: schedule-thread { $values { "continuation" "a continuation reified by " { $link callcc0 } } } diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 2cb7a3c3d0..7a67d1b531 100644 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -2,34 +2,30 @@ ! Copyright (C) 2005 Mackenzie Straight. ! See http://factorcode.org/license.txt for BSD license. IN: threads -USING: arrays init hashtables heaps io.backend kernel kernel.private -math namespaces queues sequences vectors io system sorting -continuations debugger ; +USING: arrays init hashtables heaps io.backend kernel +kernel.private math namespaces sequences vectors io system +continuations debugger dlists ; ( obj1 obj2 -- n ) - [ sleeping-ms ] 2apply - ; - : sleep-time ( -- ms ) - sleep-queue get-global - dup heap-empty? [ drop 1000 ] [ peek-heap sleeping-ms millis [-] ] if ; + sleep-queue get-global dup heap-empty? + [ drop 1000 ] [ heap-peek nip millis [-] ] if ; : run-queue ( -- queue ) \ run-queue get-global ; -: schedule-sleep ( ms continuation -- ) - sleeping construct-boa sleep-queue get-global push-heap ; +: schedule-sleep ( continuation ms -- ) + sleep-queue get-global heap-push ; : wake-up ( -- continuation ) - sleep-queue get-global pop-heap sleeping-continuation ; + sleep-queue get-global heap-pop drop ; PRIVATE> -: schedule-thread ( continuation -- ) run-queue enque ; +: schedule-thread ( continuation -- ) + run-queue push-front ; : schedule-thread-with ( obj continuation -- ) 2array schedule-thread ; @@ -38,14 +34,14 @@ PRIVATE> walker-hook [ f swap continue-with ] [ - run-queue deque dup array? + run-queue pop-back dup array? [ first2 continue-with ] [ continue ] if ] if* ; : yield ( -- ) [ schedule-thread stop ] callcc0 ; : sleep ( ms -- ) - >fixnum millis + [ schedule-sleep stop ] callcc0 drop ; + >fixnum millis + [ schedule-sleep stop ] curry callcc0 ; : in-thread ( quot -- ) [ @@ -64,10 +60,10 @@ PRIVATE> [ 0 ? io-multiplex ] if ; : idle-thread ( -- ) - run-queue queue-empty? (idle-thread) yield idle-thread ; + run-queue dlist-empty? (idle-thread) yield idle-thread ; : init-threads ( -- ) - \ run-queue set-global + \ run-queue set-global sleep-queue set-global [ idle-thread ] in-thread ; diff --git a/extra/cfdg/models/flower6/deploy.factor b/extra/cfdg/models/flower6/deploy.factor new file mode 100644 index 0000000000..d6dadc035d --- /dev/null +++ b/extra/cfdg/models/flower6/deploy.factor @@ -0,0 +1,12 @@ +USING: tools.deploy.config ; +V{ + { deploy-ui? t } + { deploy-io 1 } + { deploy-reflection 2 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { "bundle-name" "cfdg.models.flower6.app" } +} diff --git a/unmaintained/channels/authors.txt b/extra/channels/authors.txt similarity index 100% rename from unmaintained/channels/authors.txt rename to extra/channels/authors.txt diff --git a/unmaintained/channels/channels-docs.factor b/extra/channels/channels-docs.factor similarity index 100% rename from unmaintained/channels/channels-docs.factor rename to extra/channels/channels-docs.factor diff --git a/extra/channels/channels-tests.factor b/extra/channels/channels-tests.factor new file mode 100644 index 0000000000..1f2436cf5d --- /dev/null +++ b/extra/channels/channels-tests.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2005 Chris Double. All Rights Reserved. +! See http://factorcode.org/license.txt for BSD license. +! +USING: kernel tools.test math channels channels.private +sequences threads sorting ; +IN: temporary + +{ V{ 10 } } [ + V{ } clone + [ from swap push ] in-thread + 10 swap to +] unit-test + +{ 20 } [ + + [ 20 swap to ] in-thread + from +] unit-test + +{ V{ 1 2 3 4 } } [ + V{ } clone + [ from swap push ] in-thread + [ from swap push ] in-thread + [ from swap push ] in-thread + [ from swap push ] in-thread + 4 over to + 2 over to + 1 over to + 3 swap to + natural-sort +] unit-test + +{ V{ 1 2 4 9 } } [ + V{ } clone + [ 4 swap to ] in-thread + [ 2 swap to ] in-thread + [ 1 swap to ] in-thread + [ 9 swap to ] in-thread + 2dup from swap push + 2dup from swap push + 2dup from swap push + dupd from swap push + natural-sort +] unit-test diff --git a/unmaintained/channels/channels.factor b/extra/channels/channels.factor similarity index 86% rename from unmaintained/channels/channels.factor rename to extra/channels/channels.factor index 54f0d7dd4e..07b5d2f5d5 100644 --- a/unmaintained/channels/channels.factor +++ b/extra/channels/channels.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Channels - based on ideas from newsqueak -USING: kernel sequences threads continuations random math ; +USING: kernel sequences sequences.lib threads continuations random math ; IN: channels TUPLE: channel receivers senders ; @@ -15,9 +15,6 @@ GENERIC: from ( channel -- value ) : publish ( channel -- id ) - random-64 dup >r remote-channels set-at r> ; + random-256 dup >r remote-channels set-at r> ; : get-channel ( id -- channel ) remote-channels at ; diff --git a/unmaintained/channels/remote/summary.txt b/extra/channels/remote/summary.txt similarity index 100% rename from unmaintained/channels/remote/summary.txt rename to extra/channels/remote/summary.txt diff --git a/unmaintained/channels/remote/tags.txt b/extra/channels/remote/tags.txt similarity index 100% rename from unmaintained/channels/remote/tags.txt rename to extra/channels/remote/tags.txt diff --git a/unmaintained/channels/sniffer/bsd/bsd.factor b/extra/channels/sniffer/bsd/bsd.factor similarity index 100% rename from unmaintained/channels/sniffer/bsd/bsd.factor rename to extra/channels/sniffer/bsd/bsd.factor diff --git a/unmaintained/channels/sniffer/sniffer.factor b/extra/channels/sniffer/sniffer.factor similarity index 100% rename from unmaintained/channels/sniffer/sniffer.factor rename to extra/channels/sniffer/sniffer.factor diff --git a/unmaintained/channels/summary.txt b/extra/channels/summary.txt similarity index 100% rename from unmaintained/channels/summary.txt rename to extra/channels/summary.txt diff --git a/unmaintained/channels/tags.txt b/extra/channels/tags.txt similarity index 100% rename from unmaintained/channels/tags.txt rename to extra/channels/tags.txt diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index e885877a37..426ef617ca 100644 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -26,7 +26,7 @@ TUPLE: thread timeout continuation continued? ; mailbox-data dlist-empty? ; : mailbox-put ( obj mailbox -- ) - [ mailbox-data dlist-push-end ] keep + [ mailbox-data push-back ] keep [ mailbox-threads ] keep V{ } clone swap set-mailbox-threads [ thread-continuation schedule-thread ] each yield ; @@ -51,7 +51,7 @@ TUPLE: thread timeout continuation continued? ; PRIVATE> : mailbox-get* ( mailbox timeout -- obj ) (mailbox-block-if-empty) - mailbox-data dlist-pop-front ; + mailbox-data pop-front ; : mailbox-get ( mailbox -- obj ) f mailbox-get* ; @@ -59,7 +59,7 @@ PRIVATE> : mailbox-get-all* ( mailbox timeout -- array ) (mailbox-block-if-empty) [ dup mailbox-empty? ] - [ dup mailbox-data dlist-pop-front ] + [ dup mailbox-data pop-front ] [ ] unfold nip ; : mailbox-get-all ( mailbox -- array ) @@ -74,7 +74,7 @@ PRIVATE> : mailbox-get?* ( pred mailbox timeout -- obj ) 2over >r >r (mailbox-block-unless-pred) r> r> - mailbox-data dlist-remove ; inline + mailbox-data delete-node ; inline : mailbox-get? ( pred mailbox -- obj ) f mailbox-get?* ; @@ -85,21 +85,19 @@ C: process GENERIC: send ( message process -- ) -: random-pid ( -- id ) 8 big-random ; - ; + [ ] random-256 make-mailbox ; : make-linked-process ( process -- process ) #! Return a process set to run on the local node. That process is #! linked to the process on the stack. It will receive a message if #! that process terminates. - 1quotation random-pid make-mailbox ; + 1quotation random-256 make-mailbox ; PRIVATE> : self ( -- process ) @@ -206,7 +204,7 @@ MATCH-VARS: ?from ?tag ; r self random-pid r> 3array ; + >r self random-256 r> 3array ; PRIVATE> : send-synchronous ( message process -- reply ) diff --git a/extra/dlists/dlists-tests.factor b/extra/dlists/dlists-tests.factor deleted file mode 100644 index cdcee84dc0..0000000000 --- a/extra/dlists/dlists-tests.factor +++ /dev/null @@ -1,54 +0,0 @@ -IN: temporary -USING: dlists kernel strings tools.test math ; - -[ "junk" ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ string? ] swap dlist-remove -] unit-test - -[ 5 20 ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ string? ] over dlist-remove drop - [ ] dlist-each -] unit-test - -[ "junk" ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ integer? ] over dlist-remove drop - [ integer? ] over dlist-remove drop - [ ] dlist-each -] unit-test - -[ t ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ string? ] swap dlist-contains? -] unit-test - -[ t ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ integer? ] swap dlist-contains? -] unit-test - -[ f ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ string? ] over dlist-remove drop - [ string? ] swap dlist-contains? -] unit-test diff --git a/extra/dlists/dlists.factor b/extra/dlists/dlists.factor deleted file mode 100644 index 9ff7ce5f6f..0000000000 --- a/extra/dlists/dlists.factor +++ /dev/null @@ -1,100 +0,0 @@ -! Copyright (C) 2005 Mackenzie Straight. -! See http://factorcode.org/license.txt for BSD license. -IN: dlists -USING: kernel math ; - -! Double-linked lists. - -TUPLE: dlist first last ; - -: dlist construct-empty ; - -TUPLE: dlist-node data prev next ; - -C: dlist-node - -: dlist-push-end ( data dlist -- ) - [ dlist-last f ] keep - [ dlist-last [ dupd set-dlist-node-next ] when* ] keep - 2dup set-dlist-last - dup dlist-first [ 2drop ] [ set-dlist-first ] if ; - -: dlist-empty? ( dlist -- ? ) - dlist-first f = ; - -: (unlink-prev) ( dlist dnode -- ) - dup dlist-node-prev [ - dupd swap dlist-node-next swap set-dlist-node-next - ] when* - 2dup swap dlist-first eq? [ - dlist-node-next swap set-dlist-first - ] [ 2drop ] if ; - -: (unlink-next) ( dlist dnode -- ) - dup dlist-node-next [ - dupd swap dlist-node-prev swap set-dlist-node-prev - ] when* - 2dup swap dlist-last eq? [ - dlist-node-prev swap set-dlist-last - ] [ 2drop ] if ; - -: (dlist-unlink) ( dlist dnode -- ) - [ (unlink-prev) ] 2keep (unlink-next) ; - -: (dlist-pop-front) ( dlist -- data ) - [ dlist-first dlist-node-data ] keep dup dlist-first (dlist-unlink) ; - -: dlist-pop-front ( dlist -- data ) - dup dlist-empty? [ drop f ] [ (dlist-pop-front) ] if ; - -: (dlist-remove) ( dlist quot dnode -- obj/f ) - [ - [ dlist-node-data swap call ] 2keep rot [ - swapd [ (dlist-unlink) ] keep dlist-node-data nip - ] [ - dlist-node-next (dlist-remove) - ] if - ] [ - 2drop f - ] if* ; inline - -: dlist-remove ( quot dlist -- obj/f ) - #! Return first item in the dlist that when passed to the - #! predicate quotation, true is left on the stack. The - #! item is removed from the dlist. The quotation - #! must have stack effect ( obj -- bool ). - #! TODO: needs a better name. - dup dlist-first swapd (dlist-remove) ; inline - -: (dlist-contains?) ( pred dnode -- bool ) - [ - [ dlist-node-data swap call ] 2keep rot [ - 2drop t - ] [ - dlist-node-next (dlist-contains?) - ] if - ] [ - drop f - ] if* ; inline - -: dlist-contains? ( quot dlist -- obj/f ) - #! Return true if any item in the dlist that when passed to the - #! predicate quotation, true is left on the stack. - #! The 'pred' quotation must have stack effect ( obj -- bool ). - #! TODO: needs a better name. - dlist-first (dlist-contains?) ; inline - -: (dlist-each) ( quot dnode -- ) - [ - [ dlist-node-data swap call ] 2keep - dlist-node-next (dlist-each) - ] [ - drop - ] if* ; inline - -: dlist-each ( dlist quot -- ) - swap dlist-first (dlist-each) ; inline - -: dlist-length ( dlist -- length ) - 0 swap [ drop 1+ ] dlist-each ; - diff --git a/extra/dlists/tags.txt b/extra/dlists/tags.txt deleted file mode 100644 index 42d711b32b..0000000000 --- a/extra/dlists/tags.txt +++ /dev/null @@ -1 +0,0 @@ -collections diff --git a/extra/heaps/heaps-tests.factor b/extra/heaps/heaps-tests.factor deleted file mode 100644 index a8087916e7..0000000000 --- a/extra/heaps/heaps-tests.factor +++ /dev/null @@ -1,32 +0,0 @@ -! Copyright 2007 Ryan Murphy -! See http://factorcode.org/license.txt for BSD license. - -USING: kernel math tools.test heaps heaps.private ; -IN: temporary - -[ pop-heap ] unit-test-fails -[ pop-heap ] unit-test-fails - -[ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over push-heap heap-empty? ] unit-test -[ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over push-heap heap-empty? ] unit-test - -! Binary Min Heap -{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test -{ t } [ 5 3 T{ min-heap } heap-compare ] unit-test -{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test - -[ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ] -[ { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over push-heap* ] unit-test - -[ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [ - { 3 5 4 6 5 7 6 8 } over push-heap* - 3 [ dup pop-heap* ] times -] unit-test - -[ 2 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap pop-heap ] unit-test - -[ 1 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test - -[ 400 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test diff --git a/extra/heaps/heaps.factor b/extra/heaps/heaps.factor deleted file mode 100644 index 2ff9096483..0000000000 --- a/extra/heaps/heaps.factor +++ /dev/null @@ -1,112 +0,0 @@ -! Copyright (C) 2007 Ryan Murphy, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences ; -IN: heaps - - ( -- obj ) - V{ } clone heap construct-boa ; -PRIVATE> - -TUPLE: min-heap ; - -: ( -- obj ) - min-heap construct-delegate ; - -TUPLE: max-heap ; - -: ( -- obj ) - max-heap construct-delegate ; - -r left r> nth ; -: right-value ( n heap -- obj ) >r right r> nth ; -: up-value ( n vec -- obj ) >r up r> nth ; -: swap-up ( n vec -- ) >r dup up r> exchange ; -: last-index ( vec -- n ) length 1- ; - -GENERIC: heap-compare ( obj1 obj2 heap -- ? ) - -M: min-heap heap-compare drop <=> 0 > ; -M: max-heap heap-compare drop <=> 0 < ; - -: left-bounds-check? ( m heap -- ? ) - >r left r> heap-data length >= ; - -: right-bounds-check? ( m heap -- ? ) - >r right r> heap-data length >= ; - -: (up-heap) ( vec heap -- ) - [ - >r [ last-index ] keep [ up-value ] keep peek r> heap-compare - ] 2keep rot [ - >r dup last-index - [ over swap-up ] keep - up 1+ head-slice - r> (up-heap) - ] [ - 2drop - ] if ; - -: up-heap ( heap -- ) - [ heap-data ] keep (up-heap) ; - -: child ( m heap -- n ) - 2dup right-bounds-check? [ - drop left - ] [ - dupd - [ heap-data left-value ] 2keep - [ heap-data right-value ] keep heap-compare [ - right - ] [ - left - ] if - ] if ; - -: swap-down ( m heap -- ) - [ child ] 2keep heap-data exchange ; - -DEFER: down-heap - -: (down-heap) ( m heap -- ) - 2dup [ heap-data nth ] 2keep child pick - dupd [ heap-data nth swapd ] keep - heap-compare [ - -rot [ swap-down ] keep down-heap - ] [ - 3drop - ] if ; - -: down-heap ( m heap -- ) - 2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ; - -PRIVATE> - -: push-heap ( obj heap -- ) - tuck heap-data push up-heap ; - -: push-heap* ( seq heap -- ) - swap [ swap push-heap ] curry* each ; - -: peek-heap ( heap -- obj ) - heap-data first ; - -: pop-heap* ( heap -- ) - dup heap-data length 1 > [ - [ heap-data pop 0 ] keep - [ heap-data set-nth ] keep - >r 0 r> down-heap - ] [ - heap-data pop* - ] if ; - -: pop-heap ( heap -- fist ) [ heap-data first ] keep pop-heap* ; - -: heap-empty? ( heap -- ? ) - heap-data empty? ; diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 95d7d625c1..06bad872be 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,12 +1,13 @@ USING: tools.deploy.config ; -V{ - { deploy-ui? f } - { deploy-io 3 } - { deploy-reflection 1 } - { deploy-compiler? t } +H{ { deploy-math? f } + { deploy-word-defs? f } { deploy-word-props? f } - { deploy-c-types? f } - { "stop-after-last-window?" t } { deploy-name "Hello world (console)" } + { "stop-after-last-window?" t } + { deploy-c-types? f } + { deploy-compiler? f } + { deploy-io 2 } + { deploy-ui? f } + { deploy-reflection 1 } } diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 9460903ffc..44f932abb2 100644 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -122,12 +122,13 @@ ARTICLE: "collections" "Collections" { $heading "Associative mappings" } { $subsection "assocs" } { $subsection "namespaces" } -{ $subsection "graphs" } "Implementations:" { $subsection "hashtables" } { $subsection "alists" } { $heading "Other collections" } -{ $subsection "queues" } +{ $subsection "dlists" } +{ $subsection "heaps" } +{ $subsection "graphs" } { $subsection "buffers" } ; USE: io.sockets diff --git a/extra/help/markup/markup-docs.factor b/extra/help/markup/markup-docs.factor index 0af65954e6..f6ef5f8408 100644 --- a/extra/help/markup/markup-docs.factor +++ b/extra/help/markup/markup-docs.factor @@ -100,7 +100,7 @@ HELP: $link { $values { "element" "a markup element of the form " { $snippet "{ topic }" } } } { $description "Prints a link to a help article or word." } { $examples - { $markup-example { $link "queues" } } + { $markup-example { $link "dlists" } } { $markup-example { $link + } } } ; @@ -123,7 +123,7 @@ HELP: $see-also { $values { "topics" "a sequence of article names or words" } } { $description "Prints a heading followed by a series of links." } { $examples - { $markup-example { $see-also "graphs" "queues" } } + { $markup-example { $see-also "graphs" "dlists" } } } ; { $see-also $related related-words } related-words diff --git a/extra/random/random-docs.factor b/extra/random/random-docs.factor index 811b86496c..1d8334ab31 100644 --- a/extra/random/random-docs.factor +++ b/extra/random/random-docs.factor @@ -21,3 +21,11 @@ HELP: random { $values { "seq" "a sequence" } { "elt" "a random element" } } { $description "Outputs a random element of the sequence. If the sequence is empty, always outputs " { $link f } "." } { $notes "Since integers are sequences, passing an integer " { $snippet "n" } " yields a random integer in the interval " { $snippet "[0,n)" } "." } ; + +HELP: big-random +{ $values { "n" "an integer" } { "r" "a random integer" } } +{ $description "Outputs an integer with n bytes worth of bits." } ; + +HELP: random-256 +{ $values { "r" "a random integer" } } +{ $description "Outputs an random integer 256 bits in length." } ; diff --git a/extra/random/random.factor b/extra/random/random.factor index 45ce99bcea..ff4487dd27 100755 --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -93,6 +93,8 @@ PRIVATE> : big-random ( n -- r ) [ drop (random) ] map >c-uint-array byte-array>bignum ; +: random-256 ( -- r ) 8 big-random ; inline + : random ( seq -- elt ) dup empty? [ drop f diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 470cd096e1..c170a0d20a 100644 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -33,3 +33,9 @@ math.functions tools.test ; [ { 1 -1 5 2 4 } [ < ] monotonic-split [ >array ] map ] unit-test [ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ] [ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test +[ f ] [ { } singleton? ] unit-test +[ t ] [ { "asdf" } singleton? ] unit-test +[ f ] [ { "asdf" "bsdf" } singleton? ] unit-test + +[ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test +[ V{ } [ delete-random drop ] keep length ] unit-test-fails diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index d6cf1fe1dc..33cfe80fcc 100644 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -1,6 +1,5 @@ USING: combinators.lib kernel sequences math namespaces -sequences.private shuffle ; - +random sequences.private shuffle ; IN: sequences.lib ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -61,3 +60,5 @@ IN: sequences.lib : singleton? ( seq -- ? ) length 1 = ; +: delete-random ( seq -- value ) + [ length random ] keep [ nth ] 2keep delete-nth ; diff --git a/extra/springies/models/belt-tire/deploy.factor b/extra/springies/models/belt-tire/deploy.factor new file mode 100644 index 0000000000..ed522d5ee9 --- /dev/null +++ b/extra/springies/models/belt-tire/deploy.factor @@ -0,0 +1,13 @@ +USING: tools.deploy.config ; +V{ + { deploy-ui? t } + { deploy-io 2 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { "bundle-name" "Belt Tire.app" } +} diff --git a/extra/tools/deploy/deploy-docs.factor b/extra/tools/deploy/deploy-docs.factor index 29e0da1f5c..f6e9cb2882 100644 --- a/extra/tools/deploy/deploy-docs.factor +++ b/extra/tools/deploy/deploy-docs.factor @@ -2,16 +2,20 @@ USING: help.markup help.syntax words alien.c-types assocs kernel ; IN: tools.deploy -ARTICLE: "tools.deploy" "Stand-alone image deployment" -"The stand-alone image deployment tool takes a vocabulary and generates an image, which when passed to the VM, runs the vocabulary's " { $link POSTPONE: MAIN: } " hook." +ARTICLE: "tools.deploy" "Application deployment" +"The stand-alone application deployment tool compiles a vocabulary down to a native executable which runs the vocabulary's " { $link POSTPONE: MAIN: } " hook. Deployed executables do not depend on Factor being installed, and do not expose any source code, and thus are suitable for delivering commercial end-user applications." $nl "For example, we can deploy the " { $vocab-link "hello-world" } " demo which comes with Factor:" -{ $code "\"hello-world\" deploy" } -"This generates an image file named " { $snippet "hello-world.image" } ". Now we can start this image from the operating system's command line (see " { $link "runtime-cli-args" } "):" -{ $code "./factor -i=hello-world.image" "Hello world" } - -"Once the necessary deployment flags have been set, a deployment image can be generated:" -{ $subsection deploy } ; +{ $code "\"hello-ui\" deploy" } +"On Mac OS X, this yields a program named " { $snippet "Hello world.app" } ". On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } ". In both cases, running the program displays a window with a message." +$nl +"The deployment tool works by bootstrapping a fresh image, loading the vocabulary into this image, then applying various heuristics to strip the image down to minimal size." +$nl +"You must explicitly specify major subsystems which are required, as well as the level of reflection support needed. This is done by modifying the deployment configuration prior to deployment." +{ $subsection "prepare-deploy" } +"Once the necessary deployment flags have been set, the application can be deployed:" +{ $subsection deploy } +{ $see-also "ui.tools.deploy" } ; ABOUT: "tools.deploy" diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor index adee30a8bc..7c0dabc458 100755 --- a/extra/tools/deploy/deploy.factor +++ b/extra/tools/deploy/deploy.factor @@ -5,25 +5,30 @@ assocs kernel vocabs words sequences memory io system arrays continuations math definitions mirrors splitting parser classes inspector layouts vocabs.loader prettyprint.config prettyprint debugger io.streams.c io.streams.duplex io.files io.backend -quotations io.launcher words.private tools.deploy.config ; +quotations io.launcher words.private tools.deploy.config +bootstrap.image ; IN: tools.deploy @@ -57,7 +62,7 @@ IN: tools.deploy PRIVATE> : deploy* ( vm image vocab config -- ) - deploy-command-line stage2 ; + stage1 deploy-command-line stage2 ; SYMBOL: deploy-implementation diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 0b71ac5209..d59665488a 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -11,6 +11,9 @@ IN: tools.deploy.macosx : rm ( path -- ) "rm -rf \"" swap "\"" 3append run-process ; +: chmod ( path perms -- ) + [ "chmod " % % " \"" % % "\"" % ] "" make run-process ; + : bundle-dir ( -- dir ) vm parent-directory parent-directory ; @@ -19,7 +22,9 @@ IN: tools.deploy.macosx >r "Contents" path+ r> path+ copy-directory ; : copy-vm ( executable bundle-name -- vm ) - "Contents/MacOS/" path+ swap path+ vm swap [ copy-file ] keep ; + "Contents/MacOS/" path+ swap path+ vm swap + [ copy-file ] keep + [ "755" chmod ] keep ; : copy-fonts ( name -- ) "fonts/" resource-path diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 52e1486199..0322ed372f 100644 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -5,7 +5,7 @@ assocs kernel vocabs words sequences memory io system arrays continuations math definitions mirrors splitting parser classes inspector layouts vocabs.loader prettyprint.config prettyprint debugger io.streams.c io.streams.duplex io.files io.backend -quotations words.private tools.deploy.config compiler ; +quotations words.private tools.deploy.config ; IN: tools.deploy.shaker : show ( msg -- ) @@ -24,7 +24,7 @@ IN: tools.deploy.shaker "Stripping debugger" show "resource:extra/tools/deploy/shaker/strip-debugger.factor" run-file - recompile + do-parse-hook ] when ; : strip-libc ( -- ) @@ -32,7 +32,7 @@ IN: tools.deploy.shaker "Stripping manual memory management debug code" show "resource:extra/tools/deploy/shaker/strip-libc.factor" run-file - recompile + do-parse-hook ] when ; : strip-cocoa ( -- ) @@ -40,7 +40,7 @@ IN: tools.deploy.shaker "Stripping unused Cocoa methods" show "resource:extra/tools/deploy/shaker/strip-cocoa.factor" run-file - recompile + do-parse-hook ] when ; : strip-assoc ( retained-keys assoc -- newassoc ) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index dddab1aa8a..e4d4434b4e 100644 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables kernel models math namespaces sequences -timers quotations math.vectors queues combinators sorting -vectors ; +timers quotations math.vectors combinators sorting vectors +dlists ; IN: ui.gadgets TUPLE: rect loc dim ; @@ -159,7 +159,7 @@ M: array gadget-text* #! When unit testing gadgets without the UI running, the #! invalid queue is not initialized and we simply ignore #! invalidation requests. - invalid [ enque ] [ drop ] if* ; + invalid [ push-front ] [ drop ] if* ; DEFER: relayout diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index c7b4455bc7..0e337c538a 100644 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs kernel math models namespaces queues +USING: arrays assocs kernel math models namespaces sequences words strings system hashtables math.parser math.vectors tuples classes ui.gadgets timers ; IN: ui.gestures diff --git a/extra/ui/tools/deploy/deploy-docs.factor b/extra/ui/tools/deploy/deploy-docs.factor new file mode 100644 index 0000000000..4898b651a1 --- /dev/null +++ b/extra/ui/tools/deploy/deploy-docs.factor @@ -0,0 +1,14 @@ +USING: help.markup help.syntax ui.tools.deploy ; + +HELP: deploy-tool +{ $values { "vocab" "a vocabulary specifier" } } +{ $description "Opens the graphical deployment tool for the specified vocabulary." } +{ $examples { $code "\"tetris\" deploy-tool" } } ; + +ARTICLE: "ui.tools.deploy" "Application deployment UI tool" +"The application deployment UI tool provides a graphical front-end to deployment configuration. Using the tool, you can set deployment options graphically." +$nl +"To start the tool, pass a vocabulary name to a word:" +{ $subsection deploy-tool } +"Alternatively, right-click on a vocabulary presentation in the UI and choose " { $strong "Deploy tool" } " from the resulting popup menu." +{ $see-also "tools.deploy" } ; diff --git a/extra/ui/tools/tools-docs.factor b/extra/ui/tools/tools-docs.factor index e80dfe3c33..df795fa987 100644 --- a/extra/ui/tools/tools-docs.factor +++ b/extra/ui/tools/tools-docs.factor @@ -130,12 +130,14 @@ $nl { $subsection "ui-presentations" } { $subsection "ui-completion" } { $heading "Tools" } -"All development tools are integrated into a single-window " { $emphasis "workspace" } "." +"A single-window " { $emphasis "workspace" } " contains the most frequently-used tools:" { $subsection "ui-listener" } { $subsection "ui-browser" } { $subsection "ui-inspector" } { $subsection "ui-walker" } { $subsection "ui-profiler" } +"Additional tools:" +{ $subsection "ui.tools.deploy" } "Platform-specific features:" { $subsection "ui-cocoa" } ; diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index 18886ef348..fc5777ab6a 100644 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs io kernel math models namespaces -prettyprint queues sequences threads sequences words timers +prettyprint dlists sequences threads sequences words timers debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render continuations init ; IN: ui @@ -81,13 +81,13 @@ SYMBOL: windows [ invalid [ dup layout find-world [ , ] when* - ] queue-each + ] dlist-slurp ] { } make ; SYMBOL: ui-hook : init-ui ( -- ) - \ invalid set-global + \ invalid set-global V{ } clone windows set-global ; : start-ui ( -- ) diff --git a/unmaintained/channels/channels-tests.factor b/unmaintained/channels/channels-tests.factor deleted file mode 100644 index 5c339d3406..0000000000 --- a/unmaintained/channels/channels-tests.factor +++ /dev/null @@ -1,48 +0,0 @@ -! Copyright (C) 2005 Chris Double. All Rights Reserved. -! See http://factorcode.org/license.txt for BSD license. -! -USING: kernel tools.test math channels channels.private -sequences threads sorting ; -IN: temporary - -{ 3 t } [ - V{ 1 2 3 4 } clone [ delete-random ] keep length swap integer? -] unit-test - -{ V{ 10 } } [ - V{ } clone - [ from swap push ] in-thread - 10 swap to -] unit-test - -{ 20 } [ - - [ 20 swap to ] in-thread - from -] unit-test - -{ V{ 1 2 3 4 } } [ - V{ } clone - [ from swap push ] in-thread - [ from swap push ] in-thread - [ from swap push ] in-thread - [ from swap push ] in-thread - 4 over to - 2 over to - 1 over to - 3 swap to - [ <=> ] sort -] unit-test - -{ V{ 1 2 4 9 } } [ - V{ } clone - [ 4 swap to ] in-thread - [ 2 swap to ] in-thread - [ 1 swap to ] in-thread - [ 9 swap to ] in-thread - 2dup from swap push - 2dup from swap push - 2dup from swap push - dupd from swap push - [ <=> ] sort -] unit-test diff --git a/vm/Config.linux.arm b/vm/Config.linux.arm index 4b8c8415db..26acde562d 100644 --- a/vm/Config.linux.arm +++ b/vm/Config.linux.arm @@ -1,2 +1,3 @@ include vm/Config.linux include vm/Config.arm +PLAF_DLL_OBJS += vm/os-linux-arm.o diff --git a/vm/Config.unix b/vm/Config.unix index 73934d7f41..390a719c77 100644 --- a/vm/Config.unix +++ b/vm/Config.unix @@ -21,5 +21,5 @@ endif # LINKER = gcc -shared -o # LINK_WITH_ENGINE = '-Wl,-rpath,$$ORIGIN' -lfactor -LINKER = ar rcs +LINKER = $(AR) rcs LINK_WITH_ENGINE = -Wl,--whole-archive -lfactor -Wl,-no-whole-archive diff --git a/vm/debug.c b/vm/debug.c index 733f4eb49c..55ffcadca6 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -200,6 +200,7 @@ void dump_objects(F_FIXNUM type) { if(type == -1 || type_of(obj) == type) { + printf("%lx ",obj); print_nested_obj(obj,3); printf("\n"); } diff --git a/vm/os-linux-arm.c b/vm/os-linux-arm.c new file mode 100644 index 0000000000..217fb58fa7 --- /dev/null +++ b/vm/os-linux-arm.c @@ -0,0 +1,23 @@ +#include "master.h" + +void flush_icache(CELL start, CELL len) +{ + int result; + + /* XXX: why doesn't this work on Nokia n800? It should behave + identically to the below assembly. */ + /* result = syscall(__ARM_NR_cacheflush,start,start + len,0); */ + + __asm__ __volatile__ ( + "mov r0, %1\n" + "sub r1, %2, #1\n" + "mov r2, #0\n" + "swi " __sys1(__ARM_NR_cacheflush) "\n" + "mov %0, r0\n" + : "=r" (result) + : "r" (start), "r" (start + len) + : "r0","r1","r2"); + + if(result < 0) + critical_error("flush_icache() failed",result); +} diff --git a/vm/os-linux-arm.h b/vm/os-linux-arm.h index 2e3d6062ed..6e078b014d 100644 --- a/vm/os-linux-arm.h +++ b/vm/os-linux-arm.h @@ -8,7 +8,7 @@ INLINE void *ucontext_stack_pointer(void *uap) return (void *)ucontext->uc_mcontext.arm_sp; } -INLINE void flush_icache(CELL start, CELL len) -{ - syscall(__ARM_NR_cacheflush,start,start + len,0); -} +#define UAP_PROGRAM_COUNTER(ucontext) \ + (((ucontext_t *)(ucontext))->uc_mcontext.arm_pc) + +void flush_icache(CELL start, CELL len);