From 5c50103458084c9c9879ed1af8b1b2691e3206d3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Feb 2008 14:15:45 -0600 Subject: [PATCH 01/29] Minor fixes --- core/inference/class/class-tests.factor | 7 +++++++ core/optimizer/math/math.factor | 2 +- extra/locals/locals-tests.factor | 4 ++++ 3 files changed, 12 insertions(+), 1 deletion(-) diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 691010e9ca..10eae1eb99 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -288,3 +288,10 @@ cell-bits 32 = [ [ HEX: ff bitand 0 HEX: ff between? ] \ >= inlined? ] unit-test + +[ t ] [ + [ HEX: ff swap HEX: ff bitand >= ] + \ >= inlined? +] unit-test + + diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 6f535ec8e6..b7c82e402a 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -379,7 +379,7 @@ most-negative-fixnum most-positive-fixnum [a,b] >r dup dup node-in-d first node-interval swap dup node-in-d second node-literal r> execute ; inline -: foldable-comparison? ( #call word -- ) +: foldable-comparison? ( #call word -- ? ) >r dup known-comparison? [ r> perform-comparison incomparable eq? not ] [ diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index 85984ffaee..aa724c4aca 100644 --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -122,3 +122,7 @@ SYMBOL: a USE: kernel ; [ t ] [ a symbol? ] unit-test + +:: let-let-test | n | [let | n [ n 3 + ] | n ] ; + +[ 13 ] [ 10 let-let-test ] unit-test From d4b53bf4dfdeeb6b4211be172306eaaf4da146ab Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Feb 2008 14:16:22 -0600 Subject: [PATCH 02/29] New heaps work in progress --- core/heaps/heaps-tests.factor | 13 ---- core/heaps/heaps.factor | 129 ++++++++++++++++++++-------------- 2 files changed, 77 insertions(+), 65 deletions(-) diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index 92b06b866c..9c7f1e9b2f 100644 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -34,16 +34,3 @@ IN: temporary [ 0 ] [ heap-length ] unit-test [ 1 ] [ t 1 pick heap-push heap-length ] unit-test - -[ { { 1 2 } { 3 4 } { 5 6 } } ] [ - T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } } - [ [ 10 < nip ] [ 2array , ] heap-pop-while ] { } make -] unit-test -[ { { 1 2 } } ] [ - T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } } - [ [ 3 < nip ] [ 2array , ] heap-pop-while ] { } make -] unit-test -[ { } ] [ - T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } } - [ [ 1 < nip ] [ 2array , ] heap-pop-while ] { } make -] unit-test diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index cd00dc0db3..870346995c 100644 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -12,15 +12,20 @@ GENERIC: heap-pop ( heap -- value key ) GENERIC: heap-delete ( key heap -- ) GENERIC: heap-delete* ( key heap -- old ? ) GENERIC: heap-empty? ( heap -- ? ) -GENERIC: heap-length ( heap -- n ) -GENERIC# heap-pop-while 2 ( heap pred quot -- ) +GENERIC: heap-size ( heap -- n ) ( class -- heap ) >r V{ } clone heap construct-boa r> construct-delegate ; inline + +TUPLE: entry value key index ; + +: f entry construct-boa ; + PRIVATE> TUPLE: min-heap ; @@ -34,23 +39,63 @@ TUPLE: max-heap ; INSTANCE: min-heap priority-queue INSTANCE: max-heap priority-queue +M: priority-queue heap-empty? ( heap -- ? ) + heap-data empty? ; + +M: priority-queue heap-size ( heap -- n ) + heap-data length ; + 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 + +: left ( n -- m ) 1 shift 1+ ; inline + +: right ( n -- m ) 1 shift 2 + ; inline + +: up ( n -- m ) 1- 2/ ; inline + +: data-nth ( n heap -- obj ) + heap-data nth ; inline + +: up-value ( n heap -- obj ) + >r up r> data-nth ; inline + +: left-value ( n heap -- obj ) + >r left r> data-nth ; inline + +: right-value ( n heap -- obj ) + >r right r> data-nth ; inline + +: data-push ( obj heap -- ) + heap-data push ; inline + +: data-pop ( heap -- obj ) + heap-data pop ; inline + +: data-pop* ( heap -- obj ) + heap-data pop* ; inline + +: data-peek ( heap -- obj ) + heap-data peek ; inline + +: data-first ( heap -- obj ) + heap-data first ; inline + +: data-set-first ( obj heap -- ) + heap-data set-first ; inline + +: data-exchange ( m n heap -- ) + heap-data exchange ; inline GENERIC: heap-compare ( pair1 pair2 heap -- ? ) -: (heap-compare) drop [ first ] compare 0 ; inline + +: (heap-compare) drop [ entry-key ] compare 0 ; inline + M: min-heap heap-compare (heap-compare) > ; + M: max-heap heap-compare (heap-compare) < ; : heap-bounds-check? ( m heap -- ? ) - heap-data length >= ; inline + heap-size >= ; inline : left-bounds-check? ( m heap -- ? ) >r left r> heap-bounds-check? ; inline @@ -58,38 +103,35 @@ M: max-heap heap-compare (heap-compare) < ; : right-bounds-check? ( m heap -- ? ) >r right r> heap-bounds-check? ; inline -: up-heap-continue? ( vec heap -- ? ) - >r [ last-index ] keep [ up-value ] keep peek r> +: up-heap-continue? ( m up[m] heap -- ? ) + [ data-nth swap ] keep [ data-nth ] keep 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 +: up-heap ( n heap -- ) + >r dup up r> + 3dup up-heap-continue? [ + [ data-exchange ] 2keep up-heap ] [ 2drop ] if ; : (child) ( m heap -- n ) - dupd - [ heap-data left-value ] 2keep - [ heap-data right-value ] keep heap-compare + 2dup right-value + >r 2dup left-value r> + rot heap-compare [ right ] [ left ] if ; : child ( m heap -- n ) 2dup right-bounds-check? [ drop left ] [ (child) ] if ; : swap-down ( m heap -- ) - [ child ] 2keep heap-data exchange ; + [ child ] 2keep 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 down-heap-continue? [ + 2dup [ data-nth ] 2keep child pick + dupd [ data-nth swapd ] keep heap-compare [ -rot [ swap-down ] keep down-heap ] [ 3drop @@ -101,39 +143,22 @@ DEFER: down-heap PRIVATE> M: priority-queue heap-push ( value key heap -- ) - >r swap 2array r> - [ heap-data push ] keep - [ heap-data ] keep - up-heap ; + [ >r r> data-push ] keep up-heap ; : heap-push-all ( assoc heap -- ) [ swapd heap-push ] curry assoc-each ; M: priority-queue heap-peek ( heap -- value key ) - heap-data first first2 swap ; + data-first { entry-value entry-key } get-slots ; M: priority-queue heap-pop* ( heap -- ) - dup heap-data length 1 > [ - [ heap-data pop ] keep - [ heap-data set-first ] keep + dup heap-size 1 > [ + [ heap-pop ] keep + [ set-data-first ] keep 0 swap down-heap ] [ - heap-data pop* + data-pop* ] if ; -M: priority-queue heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ; - -M: priority-queue heap-empty? ( heap -- ? ) heap-data empty? ; - -M: priority-queue heap-length ( heap -- n ) heap-data length ; - -: (heap-pop-while) ( heap pred quot -- ) - pick heap-empty? [ - 3drop - ] [ - [ >r >r dup heap-peek r> call r> [ drop f ] if ] 3keep - roll [ (heap-pop-while) ] [ 3drop ] if - ] if ; - -M: priority-queue heap-pop-while ( heap pred quot -- ) - [ heap-pop ] swap [ t ] 3compose (heap-pop-while) ; +M: priority-queue heap-pop ( heap -- value key ) + dup heap-peek rot heap-pop* ; From 2535436f1908363992ba232c55635f34d0d9b642 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Feb 2008 17:07:05 -0600 Subject: [PATCH 03/29] Friedlier fep sequence printing --- vm/debug.c | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/vm/debug.c b/vm/debug.c index f15b387377..279d925bd7 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -37,15 +37,24 @@ void print_array(F_ARRAY* array, CELL nesting) { CELL length = array_capacity(array); CELL i; + bool trimmed; if(length > 10) + { + trimmed = true; length = 10; + } + else + trimmed = false; for(i = 0; i < length; i++) { printf(" "); print_nested_obj(array_nth(array,i),nesting); } + + if(trimmed) + printf("..."); } void print_nested_obj(CELL obj, F_FIXNUM nesting) From 748c2b4b339f45ad60be3a712fd7802d67ae13c2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Feb 2008 17:07:26 -0600 Subject: [PATCH 04/29] Clean up heaps and add heap-push*, heap-delete words --- core/heaps/heaps-docs.factor | 55 ++++++++-------- core/heaps/heaps-tests.factor | 66 +++++++++++++++----- core/heaps/heaps.factor | 114 ++++++++++++++++++++-------------- 3 files changed, 150 insertions(+), 85 deletions(-) mode change 100644 => 100755 core/heaps/heaps-docs.factor mode change 100644 => 100755 core/heaps/heaps-tests.factor mode change 100644 => 100755 core/heaps/heaps.factor diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor old mode 100644 new mode 100755 index 3605ec519a..e912355a5c --- a/core/heaps/heaps-docs.factor +++ b/core/heaps/heaps-docs.factor @@ -11,9 +11,9 @@ $nl { $subsection min-heap? } { $subsection } "Max-heaps sort their elements so that the maximum element is first:" -{ $subsection min-heap } -{ $subsection min-heap? } -{ $subsection } +{ $subsection max-heap } +{ $subsection max-heap? } +{ $subsection } "Both obey a protocol." $nl "Queries:" @@ -22,58 +22,61 @@ $nl { $subsection heap-peek } "Insertion:" { $subsection heap-push } +{ $subsection heap-push* } { $subsection heap-push-all } "Removal:" { $subsection heap-pop* } -{ $subsection heap-pop } ; +{ $subsection heap-pop } +{ $subsection heap-delete } ; ABOUT: "heaps" HELP: { $values { "min-heap" min-heap } } -{ $description "Create a new " { $link min-heap } "." } -{ $see-also } ; +{ $description "Create a new " { $link min-heap } "." } ; HELP: { $values { "max-heap" max-heap } } -{ $description "Create a new " { $link max-heap } "." } -{ $see-also } ; +{ $description "Create a new " { $link max-heap } "." } ; 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 } ; +{ $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." } +{ $side-effects "heap" } ; + +HELP: heap-push* +{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } { "entry" entry } } +{ $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." } +{ $side-effects "heap" } ; 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 } ; +{ $side-effects "heap" } ; 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* } ; +{ $description "Output the first element in the heap, leaving it in the heap." } ; 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 } ; +{ $description "Remove the first element from the heap." } +{ $side-effects "heap" } ; 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 } ; +{ $description "Output and remove the first element in the heap." } +{ $side-effects "heap" } ; HELP: heap-empty? { $values { "heap" heap } { "?" "a boolean" } } -{ $description "Tests if a " { $link heap } " has no nodes." } -{ $see-also heap-length heap-peek } ; +{ $description "Tests if a " { $link heap } " has no nodes." } ; -HELP: heap-length +HELP: heap-size { $values { "heap" heap } { "n" integer } } -{ $description "Returns the number of key/value pairs in the heap." } -{ $see-also heap-empty? } ; +{ $description "Returns the number of key/value pairs in the heap." } ; + +HELP: heap-delete +{ $values { "heap" heap } { "key" object } { "value" object } } +{ $description "Output and remove the first element in the heap." } +{ $side-effects "heap" } ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor old mode 100644 new mode 100755 index 9c7f1e9b2f..ce9a417476 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -1,8 +1,8 @@ -! Copyright 2007 Ryan Murphy +! Copyright 2007, 2008 Ryan Murphy, Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math namespaces tools.test -heaps heaps.private ; +heaps heaps.private math.parser random assocs sequences sorting ; IN: temporary [ heap-pop ] must-fail @@ -15,16 +15,8 @@ IN: temporary ! 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 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 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 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 +{ t } [ t 5 t 3 T{ min-heap } heap-compare ] unit-test +{ f } [ t 5 t 3 T{ max-heap } heap-compare ] 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 @@ -32,5 +24,51 @@ IN: temporary [ 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 +[ 0 ] [ heap-size ] unit-test +[ 1 ] [ t 1 pick heap-push heap-size ] unit-test + +: heap-sort ( alist -- keys ) + [ heap-push-all ] keep heap-pop-all ; + +: random-alist ( n -- alist ) + [ + [ + (random) dup number>string swap set + ] times + ] H{ } make-assoc ; + +: test-heap-sort ( n -- ? ) + random-alist dup >alist sort-keys swap heap-sort = ; + +14 [ + [ t ] swap [ 2^ test-heap-sort ] curry unit-test +] each + +: test-entry-indices ( n -- ? ) + random-alist + [ heap-push-all ] keep + heap-data dup length swap [ entry-index ] map sequence= ; + +14 [ + [ t ] swap [ 2^ test-entry-indices ] curry unit-test +] each + +: delete-random ( seq -- elt ) + dup length random dup pick nth >r swap delete-nth r> ; + +: sort-entries ( entries -- entries' ) + [ [ entry-key ] compare ] sort ; + +: delete-test ( n -- ? ) + [ + random-alist + [ heap-push-all ] keep + dup heap-data clone swap + ] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times + heap-data + [ [ entry-key ] map ] 2apply + [ natural-sort ] 2apply ; + +11 [ + [ t ] swap [ 2^ delete-test sequence= ] curry unit-test +] each diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor old mode 100644 new mode 100755 index 870346995c..64571b6990 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -1,30 +1,30 @@ -! Copyright (C) 2007 Ryan Murphy, Doug Coleman. +! Copyright (C) 2007, 2008 Ryan Murphy, Doug Coleman, +! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences arrays assocs ; +USING: kernel math sequences arrays assocs sequences.private +growable ; IN: heaps MIXIN: priority-queue -GENERIC: heap-push ( value key heap -- ) +GENERIC: heap-push* ( value key heap -- entry ) GENERIC: heap-peek ( heap -- value key ) GENERIC: heap-pop* ( heap -- ) GENERIC: heap-pop ( heap -- value key ) -GENERIC: heap-delete ( key heap -- ) -GENERIC: heap-delete* ( key heap -- old ? ) +GENERIC: heap-delete ( entry -- ) GENERIC: heap-empty? ( heap -- ? ) GENERIC: heap-size ( heap -- n ) ( class -- heap ) - >r V{ } clone heap construct-boa r> - construct-delegate ; inline + >r V{ } clone r> construct-delegate ; inline TUPLE: entry value key index ; -: f entry construct-boa ; +: ( value key -- entry ) f entry construct-boa ; PRIVATE> @@ -47,44 +47,48 @@ M: priority-queue heap-size ( heap -- n ) r up r> data-nth ; inline -: left-value ( n heap -- obj ) +: left-value ( n heap -- entry ) >r left r> data-nth ; inline -: right-value ( n heap -- obj ) +: right-value ( n heap -- entry ) >r right r> data-nth ; inline -: data-push ( obj heap -- ) - heap-data push ; inline +: data-set-nth ( entry n heap -- ) + >r [ swap set-entry-index ] 2keep r> + heap-data set-nth-unsafe ; -: data-pop ( heap -- obj ) +: data-push ( entry heap -- n ) + dup heap-size [ + swap 2dup heap-data ensure 2drop data-set-nth + ] keep ; inline + +: data-pop ( heap -- entry ) heap-data pop ; inline -: data-pop* ( heap -- obj ) +: data-pop* ( heap -- ) heap-data pop* ; inline -: data-peek ( heap -- obj ) +: data-peek ( heap -- entry ) heap-data peek ; inline -: data-first ( heap -- obj ) +: data-first ( heap -- entry ) heap-data first ; inline -: data-set-first ( obj heap -- ) - heap-data set-first ; inline - : data-exchange ( m n heap -- ) - heap-data exchange ; inline + [ tuck data-nth >r data-nth r> ] 3keep + tuck >r >r data-set-nth r> r> data-set-nth ; inline GENERIC: heap-compare ( pair1 pair2 heap -- ? ) @@ -103,18 +107,23 @@ M: max-heap heap-compare (heap-compare) < ; : right-bounds-check? ( m heap -- ? ) >r right r> heap-bounds-check? ; inline -: up-heap-continue? ( m up[m] heap -- ? ) +: continue? ( m up[m] heap -- ? ) [ data-nth swap ] keep [ data-nth ] keep heap-compare ; inline -: up-heap ( n heap -- ) +DEFER: up-heap + +: (up-heap) ( n heap -- ) >r dup up r> - 3dup up-heap-continue? [ + 3dup continue? [ [ data-exchange ] 2keep up-heap ] [ - 2drop + 3drop ] if ; +: up-heap ( n heap -- ) + over 0 > [ (up-heap) ] [ 2drop ] if ; + : (child) ( m heap -- n ) 2dup right-value >r 2dup left-value r> @@ -122,7 +131,8 @@ M: max-heap heap-compare (heap-compare) < ; [ right ] [ left ] if ; : child ( m heap -- n ) - 2dup right-bounds-check? [ drop left ] [ (child) ] if ; + 2dup right-bounds-check? + [ drop left ] [ (child) ] if ; : swap-down ( m heap -- ) [ child ] 2keep data-exchange ; @@ -130,11 +140,11 @@ M: max-heap heap-compare (heap-compare) < ; DEFER: down-heap : (down-heap) ( m heap -- ) - 2dup [ data-nth ] 2keep child pick - dupd [ data-nth swapd ] keep heap-compare [ - -rot [ swap-down ] keep down-heap - ] [ + [ child ] 2keep swapd + 3dup continue? [ 3drop + ] [ + [ data-exchange ] 2keep down-heap ] if ; : down-heap ( m heap -- ) @@ -142,23 +152,37 @@ DEFER: down-heap PRIVATE> -M: priority-queue heap-push ( value key heap -- ) - [ >r r> data-push ] keep up-heap ; +M: priority-queue heap-push* ( value key heap -- entry ) + >r dup r> [ data-push ] keep up-heap ; + +: heap-push ( value key heap -- ) heap-push* drop ; : heap-push-all ( assoc heap -- ) [ swapd heap-push ] curry assoc-each ; -M: priority-queue heap-peek ( heap -- value key ) - data-first { entry-value entry-key } get-slots ; +: >entry< ( entry -- key value ) + { entry-value entry-key } get-slots ; -M: priority-queue heap-pop* ( heap -- ) - dup heap-size 1 > [ - [ heap-pop ] keep - [ set-data-first ] keep - 0 swap down-heap +M: priority-queue heap-peek ( heap -- value key ) + data-first >entry< ; + +M: priority-queue heap-delete ( entry heap -- ) + >r entry-index r> + 2dup heap-size 1- = [ + nip data-pop* ] [ - data-pop* + [ nip data-pop ] 2keep + [ data-set-nth ] 2keep + down-heap ] if ; +M: priority-queue heap-pop* ( heap -- ) + dup data-first swap heap-delete ; + M: priority-queue heap-pop ( heap -- value key ) - dup heap-peek rot heap-pop* ; + dup data-first [ swap heap-delete ] keep >entry< ; + +: heap-pop-all ( heap -- alist ) + [ dup heap-empty? not ] + [ dup heap-pop swap 2array ] + [ ] unfold nip ; From 4cb14acff4b25f2d981b8b22a64bd356392c7b31 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Feb 2008 19:12:37 -0600 Subject: [PATCH 05/29] New alarm system --- core/heaps/heaps-docs.factor | 22 +++--- core/heaps/heaps.factor | 2 +- core/threads/threads-docs.factor | 15 +++- core/threads/threads.factor | 35 ++++++--- extra/alarms/alarms.factor | 127 +++++++++++++++---------------- extra/calendar/calendar.factor | 2 +- 6 files changed, 112 insertions(+), 91 deletions(-) diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor index e912355a5c..1c641662a9 100755 --- a/core/heaps/heaps-docs.factor +++ b/core/heaps/heaps-docs.factor @@ -18,7 +18,7 @@ $nl $nl "Queries:" { $subsection heap-empty? } -{ $subsection heap-length } +{ $subsection heap-size } { $subsection heap-peek } "Insertion:" { $subsection heap-push } @@ -40,43 +40,43 @@ HELP: { $description "Create a new " { $link max-heap } "." } ; HELP: heap-push -{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } } +{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } } { $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." } { $side-effects "heap" } ; HELP: heap-push* -{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } { "entry" entry } } +{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } { "entry" entry } } { $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." } { $side-effects "heap" } ; HELP: heap-push-all -{ $values { "assoc" assoc } { "heap" heap } } +{ $values { "assoc" assoc } { "heap" "a heap" } } { $description "Push every key/value pair of an assoc onto a heap." } { $side-effects "heap" } ; HELP: heap-peek -{ $values { "heap" heap } { "key" object } { "value" object } } +{ $values { "heap" "a heap" } { "key" object } { "value" object } } { $description "Output the first element in the heap, leaving it in the heap." } ; HELP: heap-pop* -{ $values { "heap" heap } } +{ $values { "heap" "a heap" } } { $description "Remove the first element from the heap." } { $side-effects "heap" } ; HELP: heap-pop -{ $values { "heap" heap } { "key" object } { "value" object } } +{ $values { "heap" "a heap" } { "key" object } { "value" object } } { $description "Output and remove the first element in the heap." } { $side-effects "heap" } ; HELP: heap-empty? -{ $values { "heap" heap } { "?" "a boolean" } } -{ $description "Tests if a " { $link heap } " has no nodes." } ; +{ $values { "heap" "a heap" } { "?" "a boolean" } } +{ $description "Tests if a heap has no nodes." } ; HELP: heap-size -{ $values { "heap" heap } { "n" integer } } +{ $values { "heap" "a heap" } { "n" integer } } { $description "Returns the number of key/value pairs in the heap." } ; HELP: heap-delete -{ $values { "heap" heap } { "key" object } { "value" object } } +{ $values { "heap" "a heap" } { "key" object } { "value" object } } { $description "Output and remove the first element in the heap." } { $side-effects "heap" } ; diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index 64571b6990..158e298631 100755 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -11,7 +11,7 @@ GENERIC: heap-push* ( value key heap -- entry ) GENERIC: heap-peek ( heap -- value key ) GENERIC: heap-pop* ( heap -- ) GENERIC: heap-pop ( heap -- value key ) -GENERIC: heap-delete ( entry -- ) +GENERIC: heap-delete ( entry heap -- ) GENERIC: heap-empty? ( heap -- ? ) GENERIC: heap-size ( heap -- n ) diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor index 57e1c4f5fb..a8e4eef587 100755 --- a/core/threads/threads-docs.factor +++ b/core/threads/threads-docs.factor @@ -17,7 +17,11 @@ ARTICLE: "threads-start/stop" "Starting and stopping threads" ARTICLE: "threads-yield" "Yielding and suspending threads" "Yielding to other threads:" { $subsection yield } +"Sleeping for a period of time:" { $subsection sleep } +"Interruptible sleep:" +{ $subsection nap } +{ $subsection interrupt } "Threads can be suspended and woken up at some point in the future when a condition is satisfied:" { $subsection suspend } { $subsection resume } @@ -104,7 +108,16 @@ HELP: yield HELP: sleep { $values { "ms" "a non-negative integer" } } -{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds. It will not get woken up before this time period elapses, but since the multitasker is co-operative, the precise wakeup time is dependent on when other threads yield." } ; +{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds." } +{ $errors "Throws an error if another thread interrupted the sleep with " { $link interrupt } "." } ; + +HELP: nap +{ $values { "ms/f" "a non-negative integer or " { $link f } } { "?" "a boolean indicating whether the thread was interrupted" } } +{ $description "Suspends the current thread until another thread interrupts it with " { $link interrupt } ". If the input parameter is not " { $link f } ", then the thread will also wake up if the timeout expires before an interrupt is received." } ; + +HELP: interrupt +{ $values { "thread" thread } } +{ $description "Interrupts a sleeping thread." } ; HELP: suspend { $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "obj" object } } diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 23b1f04364..7a059c8fbe 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -13,7 +13,7 @@ TUPLE: thread name quot error-handler exit-handler id continuation state -mailbox variables ; +mailbox variables sleep-entry ; : self ( -- thread ) 40 getenv ; inline @@ -86,19 +86,25 @@ PRIVATE> r check-registered r> sleep-queue heap-push ; + >r check-registered dup r> sleep-queue heap-push* + swap set-thread-sleep-entry ; -: wake-up? ( heap -- ? ) +: expire-sleep? ( heap -- ? ) dup heap-empty? [ drop f ] [ heap-peek nip millis <= ] if ; -: wake-up ( -- ) +: expire-sleep ( thread -- ) + f over set-thread-sleep-entry resume ; + +: expire-sleep-loop ( -- ) sleep-queue - [ dup wake-up? ] [ dup heap-pop drop resume ] [ ] while + [ dup expire-sleep? ] + [ dup heap-pop drop expire-sleep ] + [ ] while drop ; : next ( -- ) - wake-up + expire-sleep-loop run-queue pop-back dup array? [ first2 ] [ f swap ] if dup set-self f over set-thread-state @@ -127,14 +133,23 @@ PRIVATE> : yield ( -- ) [ resume ] "yield" suspend drop ; +: nap ( ms/f -- ? ) + [ + >fixnum millis + [ schedule-sleep ] curry "sleep" + ] [ + [ drop ] "interrupt" + ] if* suspend ; + : sleep ( ms -- ) - >fixnum millis + - [ schedule-sleep ] curry - "sleep" suspend drop ; + nap [ "Sleep interrupted" throw ] when ; + +: interrupt ( thread -- ) + dup thread-sleep-entry [ sleep-queue heap-delete ] when* + t swap resume-with ; : (spawn) ( thread -- ) [ - resume [ + resume-now [ dup set-self dup register-thread init-namespaces diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index 40eda02fac..03d16b892d 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -1,87 +1,80 @@ -! Copyright (C) 2007 Doug Coleman. +! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays calendar combinators concurrency.messaging -threads generic init kernel math namespaces sequences ; +USING: arrays calendar combinators generic init kernel math +namespaces sequences heaps boxes threads debugger quotations ; IN: alarms -TUPLE: alarm time quot ; +TUPLE: alarm time interval quot entry ; -C: alarm +: check-alarm + pick timestamp? [ "Not a timestamp" throw ] unless + over dup dt? swap not or [ "Not a dt" throw ] unless + dup callable? [ "Not a quotation" throw ] unless ; inline - ( time delay quot -- alarm ) + check-alarm alarm construct-boa ; -! for now a V{ }, eventually a min-heap to store alarms +! Global min-heap SYMBOL: alarms -SYMBOL: alarm-receiver -SYMBOL: alarm-looper +SYMBOL: alarm-thread -: add-alarm ( alarm -- ) - alarms get-global push ; +: notify-alarm-thread ( -- ) + alarm-thread get-global interrupt ; -: remove-alarm ( alarm -- ) - alarms get-global delete ; +: add-alarm ( time delay quot -- alarm ) + [ + dup dup alarm-time alarms get-global heap-push* + swap alarm-entry >box + notify-alarm-thread + ] keep ; -: handle-alarm ( alarm -- ) - dup delegate { - { "register" [ add-alarm ] } - { "unregister" [ remove-alarm ] } - } case ; +: cancel-alarm ( alarm -- ) + alarm-entry box> alarms get-global heap-delete ; -: expired-alarms ( -- seq ) - now alarms get-global - [ alarm-time <=> 0 > ] with subset ; +: alarm-expired? ( alarm now -- ? ) + >r alarm-time r> <=> 0 <= ; -: unexpired-alarms ( -- seq ) - now alarms get-global - [ alarm-time <=> 0 <= ] with subset ; +: reschedule-alarm ( alarm -- ) + dup alarm-time over alarm-interval +dt + over set-alarm-time + add-alarm drop ; : call-alarm ( alarm -- ) - alarm-quot "Alarm invocation" spawn drop ; + dup alarm-quot try + dup alarm-entry box> drop + dup alarm-interval [ reschedule-alarm ] [ drop ] if ; -: do-alarms ( -- ) - expired-alarms [ call-alarm ] each - unexpired-alarms alarms set-global ; +: (trigger-alarms) ( alarms now -- ) + over heap-empty? [ + 2drop + ] [ + over heap-peek drop over alarm-expired? [ + over heap-pop drop call-alarm + (trigger-alarms) + ] [ + 2drop + ] if + ] if ; -: alarm-receive-loop ( -- ) - receive dup alarm? [ handle-alarm ] [ drop ] if - alarm-receive-loop ; +: trigger-alarms ( alarms -- ) + now (trigger-alarms) ; -: start-alarm-receiver ( -- ) - [ - alarm-receive-loop - ] "Alarm receiver" spawn alarm-receiver set-global ; +: next-alarm ( alarms -- ms ) + dup heap-empty? + [ drop f ] [ + heap-peek drop alarm-time now + [ timestamp>unix-time ] 2apply [-] 1000 * + ] if ; -: alarm-loop ( -- ) - alarms get-global empty? [ - do-alarms - ] unless 100 sleep alarm-loop ; +: alarm-thread-loop ( -- ) + alarms get-global + dup next-alarm nap drop + dup trigger-alarms + alarm-thread-loop ; -: start-alarm-looper ( -- ) - [ - alarm-loop - ] "Alarm looper" spawn alarm-looper set-global ; +: init-alarms ( -- ) + alarms set-global + [ alarm-thread-loop ] "Alarms" spawn + alarm-thread set-global ; -: send-alarm ( str alarm -- ) - over set-delegate - alarm-receiver get-global send ; - -: start-alarm-daemon ( -- ) - alarms get-global [ V{ } clone alarms set-global ] unless - start-alarm-looper - start-alarm-receiver ; - -[ start-alarm-daemon ] "alarms" add-init-hook -PRIVATE> - -: register-alarm ( alarm -- ) - "register" send-alarm ; - -: unregister-alarm ( alarm -- ) - "unregister" send-alarm ; - -: change-alarm ( alarm-old alarm-new -- ) - "register" send-alarm - "unregister" send-alarm ; - -! Example: -! 5 seconds from-now [ "hi" print flush ] register-alarm +[ init-alarms ] "alarms" add-init-hook diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 5b89d6e8c5..86dc973a9a 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -223,7 +223,7 @@ M: timestamp <=> ( ts1 ts2 -- n ) [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ; : unix-1970 ( -- timestamp ) - 1970 1 1 0 0 0 0 ; + 1970 1 1 0 0 0 0 ; foldable : unix-time>timestamp ( n -- timestamp ) >r unix-1970 r> seconds +dt ; From d47433a48d0a36d4dd933b680193c81d38767fd6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Feb 2008 19:12:55 -0600 Subject: [PATCH 06/29] New I/O timeout system --- extra/http/client/client.factor | 2 +- extra/http/server/server.factor | 2 +- extra/io/launcher/launcher-docs.factor | 5 +- extra/io/launcher/launcher.factor | 8 ++- extra/io/nonblocking/nonblocking.factor | 11 ++-- extra/io/timeouts/timeouts-docs.factor | 15 +++-- extra/io/timeouts/timeouts.factor | 76 ++++------------------- extra/io/windows/launcher/launcher.factor | 12 +++- extra/smtp/server/server.factor | 2 +- 9 files changed, 44 insertions(+), 89 deletions(-) diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 679d603708..7945950acb 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -47,7 +47,7 @@ DEFER: http-get-stream dispose "location" swap peek-at nip http-get-stream ] when ; -: default-timeout 60 1000 * over set-timeout ; +: default-timeout 1 minutes over set-timeout ; : http-get-stream ( url -- code headers stream ) #! Opens a stream for reading from an HTTP URL. diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 957a82d09f..112bfc3673 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -50,7 +50,7 @@ IN: http.server : httpd ( port -- ) internet-server "http.server" [ - 60000 stdio get set-timeout + 1 minutes stdio get set-timeout readln [ parse-request ] when* ] with-server ; diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 3a557e9fd5..48b2a01b7d 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax quotations kernel io math ; +USING: help.markup help.syntax quotations kernel io math +calendar ; IN: io.launcher HELP: +command+ @@ -77,7 +78,7 @@ $nl "This is used in situations where you want a spawn child process with some overridden environment variables." } ; HELP: +timeout+ -{ $description "Launch descriptor key. If set, specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ; +{ $description "Launch descriptor key. If set to a " { $link dt } ", specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ; HELP: default-descriptor { $description "Association storing default values for launch descriptor keys." } ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index eda4332473..021ea487fc 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -10,14 +10,14 @@ SYMBOL: processes [ H{ } clone processes set-global ] "io.launcher" add-init-hook -TUPLE: process handle status killed? lapse ; +TUPLE: process handle status killed? timeout ; HOOK: register-process io-backend ( process -- ) M: object register-process drop ; : ( handle -- process ) - f f process construct-boa + f f f process construct-boa V{ } clone over processes get set-at dup register-process ; @@ -115,7 +115,9 @@ HOOK: kill-process* io-backend ( handle -- ) t over set-process-killed? process-handle [ kill-process* ] when* ; -M: process get-lapse process-lapse ; +M: process timeout process-timeout ; + +M: process set-timeout set-process-timeout ; M: process timed-out kill-process ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 72507f26b6..6798f37887 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -13,11 +13,12 @@ SYMBOL: default-buffer-size TUPLE: port handle error -lapse +timeout type eof? ; -! Ports support the lapse protocol -M: port get-lapse port-lapse ; +M: port timeout port-timeout ; + +M: port set-timeout set-port-timeout ; SYMBOL: closed @@ -28,12 +29,10 @@ GENERIC: init-handle ( handle -- ) GENERIC: close-handle ( handle -- ) : ( handle buffer type -- port ) - pick init-handle - { + pick init-handle { set-port-handle set-delegate set-port-type - set-port-lapse } port construct ; : ( handle type -- port ) diff --git a/extra/io/timeouts/timeouts-docs.factor b/extra/io/timeouts/timeouts-docs.factor index a704e3473a..c03520bb56 100755 --- a/extra/io/timeouts/timeouts-docs.factor +++ b/extra/io/timeouts/timeouts-docs.factor @@ -1,14 +1,13 @@ IN: io.timeouts -USING: help.markup help.syntax math kernel ; +USING: help.markup help.syntax math kernel calendar ; -HELP: get-lapse -{ $values { "obj" object } { "lapse" lapse } } -{ $contract "Outputs an object's timeout lapse descriptor." } ; +HELP: timeout +{ $values { "obj" object } { "dt/f" "a " { $link dt } " or " { $link f } } } +{ $contract "Outputs an object's timeout." } ; HELP: set-timeout -{ $values { "ms" integer } { "obj" object } } -{ $contract "Sets an object's timeout, in milliseconds." } -{ $notes "The default implementation delegates the call to the object's timeout lapse descriptor." } ; +{ $values { "dt/f" "a " { $link dt } " or " { $link f } } { "obj" object } } +{ $contract "Sets an object's timeout." } ; HELP: timed-out { $values { "obj" object } } @@ -20,9 +19,9 @@ HELP: with-timeout ARTICLE: "io.timeouts" "I/O timeout protocol" "Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed." +{ $subsection timeout } { $subsection set-timeout } "The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations." -{ $subsection get-lapse } { $subsection timed-out } "A combinator to be used in operations which can time out:" { $subsection with-timeout } diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor index 0bae855399..966383ae23 100755 --- a/extra/io/timeouts/timeouts.factor +++ b/extra/io/timeouts/timeouts.factor @@ -1,79 +1,27 @@ ! Copyright (C) 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math system dlists namespaces assocs init -threads io.streams.duplex ; +USING: kernel calendar alarms io.streams.duplex ; IN: io.timeouts -TUPLE: lapse entry timeout cutoff ; - -: f 0 0 \ lapse construct-boa ; - ! Won't need this with new slot accessors -GENERIC: get-lapse ( obj -- lapse ) +GENERIC: timeout ( obj -- dt/f ) +GENERIC: set-timeout ( dt/f obj -- ) -GENERIC: set-timeout ( ms obj -- ) - -M: object set-timeout get-lapse set-timeout ; - -M: lapse set-timeout set-lapse-timeout ; - -: timeout ( obj -- ms ) get-lapse lapse-timeout ; -: entry ( obj -- dlist-node ) get-lapse lapse-entry ; -: set-entry ( obj dlist-node -- ) get-lapse set-lapse-entry ; -: cutoff ( obj -- ms ) get-lapse lapse-cutoff ; -: set-cutoff ( ms obj -- ) get-lapse set-lapse-cutoff ; - -! Won't need this with inheritance -TUPLE: duplex-stream-lapse stream ; - -M: duplex-stream-lapse set-timeout - duplex-stream-lapse-stream 2dup +M: duplex-stream set-timeout + 2dup duplex-stream-in set-timeout duplex-stream-out set-timeout ; -M: duplex-stream get-lapse duplex-stream-lapse construct-boa ; - -SYMBOL: timeout-queue - -: timeout? ( lapse -- ? ) - cutoff dup zero? not swap millis < and ; - -timeout-queue global [ [ ] unless* ] change-at - -: unqueue-timeout ( obj -- ) - entry [ - timeout-queue get-global swap delete-node - ] when* ; - -: queue-timeout ( obj -- ) - dup timeout-queue get-global push-front* - swap set-entry ; - GENERIC: timed-out ( obj -- ) M: object timed-out drop ; -: expire-timeouts ( -- ) - timeout-queue get-global dup dlist-empty? [ drop ] [ - dup peek-back timeout? - [ pop-back timed-out expire-timeouts ] [ drop ] if - ] if ; - -: begin-timeout ( obj -- ) - dup timeout dup zero? [ - 2drop - ] [ - millis + over set-cutoff - dup unqueue-timeout queue-timeout - ] if ; +: queue-timeout ( obj timeout -- alarm ) + from-now f rot [ timed-out ] curry add-alarm ; : with-timeout ( obj quot -- ) - over begin-timeout keep unqueue-timeout ; inline - -: expiry-thread ( -- ) - expire-timeouts 5000 sleep expiry-thread ; - -: start-expiry-thread ( -- ) - [ expiry-thread ] "I/O expiry" spawn drop ; - -[ start-expiry-thread ] "io.timeouts" add-init-hook + over dup timeout dup [ + queue-timeout slip cancel-alarm + ] [ + 2drop call + ] if ; inline diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 6f79388016..58e3c0ba69 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -146,10 +146,16 @@ M: windows-io kill-process* ( handle -- ) : wait-loop ( -- ) processes get dup assoc-empty? - [ drop t ] [ wait-for-processes ] if - [ 250 sleep ] when ; + [ drop f nap drop ] + [ wait-for-processes [ 100 nap drop ] when ] if ; + +SYMBOL: wait-thread : start-wait-thread ( -- ) - [ wait-loop t ] "Process wait" spawn-server drop ; + [ wait-loop t ] "Process wait" spawn-server + wait-thread set-global ; + +M: windows-io register-process + drop wait-thread get-global interrupt ; [ start-wait-thread ] "io.windows.launcher" add-init-hook diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor index b89b351f9e..eb628156f2 100755 --- a/extra/smtp/server/server.factor +++ b/extra/smtp/server/server.factor @@ -66,7 +66,7 @@ SYMBOL: data-mode "Starting SMTP server on port " write dup . flush "127.0.0.1" swap [ accept [ - 60000 stdio get set-timeout + 1 minutes stdio get set-timeout "220 hello\r\n" write flush process global [ flush ] bind From 4ceb51ccbbde0bd17f5491152547cb396d308843 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Feb 2008 19:13:11 -0600 Subject: [PATCH 07/29] threads. now shows sleeping threads --- extra/tools/threads/threads.factor | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/extra/tools/threads/threads.factor b/extra/tools/threads/threads.factor index 0d924733c4..3313a56964 100755 --- a/extra/tools/threads/threads.factor +++ b/extra/tools/threads/threads.factor @@ -2,17 +2,24 @@ ! See http://factorcode.org/license.txt for BSD license. IN: tools.threads USING: threads kernel prettyprint prettyprint.config -io io.styles sequences assocs namespaces sorting boxes ; +io io.styles sequences assocs namespaces sorting boxes +heaps.private system math math.parser ; : thread. ( thread -- ) dup thread-id pprint-cell dup thread-name over [ write-object ] with-cell - thread-state "running" or [ write ] with-cell ; + dup thread-state "running" or [ write ] with-cell + [ + thread-sleep-entry [ + entry-key millis [-] number>string write + " ms" write + ] when* + ] with-cell ; : threads. ( -- ) standard-table-style [ [ - { "ID" "Name" "Waiting on" } + { "ID" "Name" "Waiting on" "Remaining sleep" } [ [ write ] with-cell ] each ] with-row From 217ca36756ecf4cab2f25b02b58523d8236c3c2f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Feb 2008 19:14:28 -0600 Subject: [PATCH 08/29] bunny doesn't need to use timers --- extra/bunny/bunny.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index 7cf6132925..963379896d 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types arrays sequences math math.vectors math.matrices math.parser io io.files kernel opengl -opengl.gl opengl.glu shuffle http.client vectors timers +opengl.gl opengl.glu shuffle http.client vectors namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting combinators tools.time system combinators.lib combinators.cleave float-arrays continuations opengl.demo-support multiline From b7ba2d77a2c55321e13afddb148f1a2086573710 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Feb 2008 19:14:50 -0600 Subject: [PATCH 09/29] Removed extra/timers, superceded by alarms --- extra/models/models.factor | 18 ++++++---- extra/timers/authors.txt | 1 - extra/timers/summary.txt | 1 - extra/timers/timers-docs.factor | 36 ------------------- extra/timers/timers.factor | 30 ---------------- extra/ui/gadgets/gadgets.factor | 6 ++-- extra/ui/gestures/gestures.factor | 13 ++++--- extra/ui/tools/listener/listener-tests.factor | 4 +-- extra/ui/tools/search/search-tests.factor | 7 ++-- extra/ui/tools/tools-tests.factor | 4 +-- extra/ui/ui-docs.factor | 3 +- extra/ui/ui.factor | 6 ++-- extra/ui/windows/windows.factor | 5 ++- 13 files changed, 30 insertions(+), 104 deletions(-) delete mode 100644 extra/timers/authors.txt delete mode 100644 extra/timers/summary.txt delete mode 100644 extra/timers/timers-docs.factor delete mode 100644 extra/timers/timers.factor diff --git a/extra/models/models.factor b/extra/models/models.factor index a6f1f6909a..6d2b0907c5 100755 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: generic kernel math sequences timers arrays assocs ; +USING: generic kernel math sequences arrays assocs alarms ; IN: models TUPLE: model value connections dependencies ref locked? ; @@ -174,7 +174,7 @@ TUPLE: history back forward ; dup history-forward delete-all dup history-back (add-history) ; -TUPLE: delay model timeout ; +TUPLE: delay model timeout alarm ; : update-delay-model ( delay -- ) dup delay-model model-value swap set-model ; @@ -185,12 +185,18 @@ TUPLE: delay model timeout ; [ set-delay-model ] 2keep [ add-dependency ] keep ; -M: delay model-changed nip 0 over delay-timeout add-timer ; +: cancel-delay ( delay -- ) + delay-model-alarm [ cancel-alarm ] when* ; + +: start-delay ( delay -- ) + now over delay-model-timeout dt+ f + pick [ f over set-delay-alarm update-delay-model ] curry + add-alarm swap set-delay-model-alarm ; + +M: delay model-changed nip start-delay ; M: delay model-activated update-delay-model ; -M: delay tick dup remove-timer update-delay-model ; - GENERIC: range-value ( model -- value ) GENERIC: range-page-value ( model -- value ) GENERIC: range-min-value ( model -- value ) diff --git a/extra/timers/authors.txt b/extra/timers/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/extra/timers/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/timers/summary.txt b/extra/timers/summary.txt deleted file mode 100644 index 2b0c0b053f..0000000000 --- a/extra/timers/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Simple low-resolution timers diff --git a/extra/timers/timers-docs.factor b/extra/timers/timers-docs.factor deleted file mode 100644 index 05a52516ff..0000000000 --- a/extra/timers/timers-docs.factor +++ /dev/null @@ -1,36 +0,0 @@ -USING: help.syntax help.markup classes kernel ; -IN: timers - -HELP: init-timers -{ $description "Initializes the timer code." } -{ $notes "This word is automatically called when the UI is initialized, and it should only be called manually if timers are being used outside of the UI." } ; - -HELP: tick -{ $values { "object" object } } -{ $description "Called to notify an object registered with a timer that the timer has fired." } ; - -HELP: add-timer -{ $values { "object" object } { "delay" "a positive integer" } { "initial" "a positive integer" } } -{ $description "Registers a timer. Every " { $snippet "delay" } " milliseconds, " { $link tick } " will be called on the object. The initial delay from the time " { $link add-timer } " is called to when " { $link tick } " is first called is " { $snippet "initial" } " milliseconds." } ; - -HELP: remove-timer -{ $values { "object" object } } -{ $description "Unregisters a timer." } ; - -HELP: do-timers -{ $description "Fires all registered timers which are due to fire." } -{ $notes "This word is automatically called from the UI event loop, and it should only be called manually if timers are being used outside of the UI." } ; - -{ init-timers add-timer remove-timer tick do-timers } related-words - -ARTICLE: "timers" "Timers" -"Timers can be added and removed:" -{ $subsection add-timer } -{ $subsection remove-timer } -"Classes must implement a generic word so that their instances can handle timer ticks:" -{ $subsection tick } -"Timers can be used outside of the UI, however they must be initialized with an explicit call, and fired manually:" -{ $subsection init-timers } -{ $subsection do-timers } ; - -ABOUT: "timers" diff --git a/extra/timers/timers.factor b/extra/timers/timers.factor deleted file mode 100644 index e3a510287b..0000000000 --- a/extra/timers/timers.factor +++ /dev/null @@ -1,30 +0,0 @@ -! Copyright (C) 2005, 2006 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel math namespaces sequences system ; -IN: timers - -TUPLE: timer object delay next ; - -: ( object delay initial -- timer ) - millis + timer construct-boa ; - -GENERIC: tick ( object -- ) - -: timers \ timers get-global ; - -: init-timers ( -- ) H{ } clone \ timers set-global ; - -: add-timer ( object delay initial -- ) - pick >r r> timers set-at ; - -: remove-timer ( object -- ) timers delete-at ; - -: advance-timer ( ms timer -- ) - [ timer-delay + ] keep set-timer-next ; - -: do-timer ( ms timer -- ) - dup timer-next pick <= - [ [ advance-timer ] keep timer-object tick ] [ 2drop ] if ; - -: do-timers ( -- ) - millis timers values [ do-timer ] with each ; diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 0ac43af756..37c5684cc9 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables kernel models math namespaces sequences -timers quotations math.vectors combinators sorting vectors -dlists models ; +quotations math.vectors combinators sorting vectors dlists +models ; IN: ui.gadgets TUPLE: rect loc dim ; diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index 2a3e344a9e..2d3e8f6835 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs kernel math models namespaces sequences words strings system hashtables math.parser -math.vectors tuples classes ui.gadgets timers combinators.lib ; +math.vectors tuples classes ui.gadgets combinators.lib ; IN: ui.gestures : set-gestures ( class hash -- ) "gestures" set-word-prop ; @@ -107,20 +107,19 @@ SYMBOL: double-click-timeout : drag-gesture ( -- ) hand-buttons get-global first button-gesture ; -TUPLE: drag-timer ; +SYMBOL: drag-timer -M: drag-timer tick drop drag-gesture ; - -drag-timer construct-empty drag-timer set-global + drag-timer set-global : start-drag-timer ( -- ) hand-buttons get-global empty? [ - drag-timer get-global 100 300 add-timer + now 300 milliseconds dt+ 100 milliseconds + [ drag-gesture ] add-alarm drag-timer get-global >box ] when ; : stop-drag-timer ( -- ) hand-buttons get-global empty? [ - drag-timer get-global remove-timer + drag-timer get-global box> cancel-alarm ] when ; : fire-motion ( -- ) diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor index f0516f54b9..0024fa725f 100755 --- a/extra/ui/tools/listener/listener-tests.factor +++ b/extra/ui/tools/listener/listener-tests.factor @@ -1,12 +1,10 @@ USING: continuations documents ui.tools.interactor ui.tools.listener hashtables kernel namespaces parser sequences -timers tools.test ui.commands ui.gadgets ui.gadgets.editors +tools.test ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.panes vocabs words tools.test.ui slots.private threads ; IN: temporary -timers [ init-timers ] unless - [ f ] [ "word" source-editor command-map empty? ] unit-test [ ] [ [ ] with-grafted-gadget ] unit-test diff --git a/extra/ui/tools/search/search-tests.factor b/extra/ui/tools/search/search-tests.factor index 47ae786f59..49bd1a3837 100755 --- a/extra/ui/tools/search/search-tests.factor +++ b/extra/ui/tools/search/search-tests.factor @@ -1,11 +1,9 @@ USING: assocs ui.tools.search help.topics io.files io.styles -kernel namespaces sequences source-files threads timers +kernel namespaces sequences source-files threads tools.test ui.gadgets ui.gestures vocabs vocabs.loader words tools.test.ui debugger ; IN: temporary -timers get [ init-timers ] unless - [ f ] [ "no such word with this name exists, certainly" f f @@ -16,7 +14,7 @@ timers get [ init-timers ] unless : update-live-search ( search -- seq ) dup [ - 300 sleep do-timers + 300 sleep live-search-list control-value ] with-grafted-gadget ; @@ -33,7 +31,6 @@ timers get [ init-timers ] unless dup [ { "set-word-prop" } over live-search-field set-control-value 300 sleep - do-timers search-value \ set-word-prop eq? ] with-grafted-gadget ] unit-test diff --git a/extra/ui/tools/tools-tests.factor b/extra/ui/tools/tools-tests.factor index 919d1705af..ff2444e43b 100755 --- a/extra/ui/tools/tools-tests.factor +++ b/extra/ui/tools/tools-tests.factor @@ -1,6 +1,6 @@ USING: ui.tools ui.tools.interactor ui.tools.listener ui.tools.search ui.tools.workspace kernel models namespaces -sequences timers tools.test ui.gadgets ui.gadgets.buttons +sequences tools.test ui.gadgets ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.presentations ui.gadgets.scrollers vocabs tools.test.ui ui ; IN: temporary @@ -12,8 +12,6 @@ IN: temporary ] unit-test ] with-scope -timers get [ init-timers ] unless - [ ] [ "w" set ] unit-test [ ] [ "w" get com-scroll-up ] unit-test [ ] [ "w" get com-scroll-down ] unit-test diff --git a/extra/ui/ui-docs.factor b/extra/ui/ui-docs.factor index 7fbd6dbac1..9b3a05e101 100755 --- a/extra/ui/ui-docs.factor +++ b/extra/ui/ui-docs.factor @@ -167,7 +167,7 @@ ARTICLE: "ui-backend-init" "UI initialization and the event loop" { $subsection start-ui } "The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down." $nl -"The event loop must not block. Instead, it should poll for pending events, then call " { $link ui-step } ", which performs pending layout, runs timers and sleeps for 10 milliseconds, or until a Factor thread wakes up." ; +"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-step } ", which performs pending layout and sleeps for 10 milliseconds." ; ARTICLE: "ui-backend-windows" "UI backend window management" "The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:" @@ -368,7 +368,6 @@ $nl { $subsection "ui-paint" } { $subsection "ui-control-impl" } { $subsection "clipboard-protocol" } -{ $subsection "timers" } { $see-also "ui-layout-impl" } ; ARTICLE: "ui" "UI framework" diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index d5d968c4e6..1de0dac6f0 100755 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs io kernel math models namespaces prettyprint dlists sequences threads sequences words -timers debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks +debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render continuations init combinators hashtables ; IN: ui @@ -131,8 +131,7 @@ SYMBOL: ui-hook graft-queue [ notify ] dlist-slurp ; : ui-step ( -- ) - [ do-timers notify-queued layout-queued redraw-worlds ] - assert-depth ; + [ notify-queued layout-queued redraw-worlds ] assert-depth ; : open-world-window ( world -- ) dup pref-dim over set-gadget-dim dup relayout graft ui-step ; @@ -156,7 +155,6 @@ M: object close-window find-world [ ungraft ] when* ; : start-ui ( -- ) - init-timers restore-windows? [ restore-windows ] [ diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 3a519e49d2..80c03a3f5d 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -5,9 +5,8 @@ ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel math math.vectors namespaces prettyprint sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.nt -windows threads timers libc combinators -continuations command-line shuffle opengl ui.render unicode.case -ascii math.bitfields ; +windows threads libc combinators continuations command-line +shuffle opengl ui.render unicode.case ascii math.bitfields ; IN: ui.windows TUPLE: windows-ui-backend ; From bbad200a019867c3a85b7502299a7995b8e873d4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Feb 2008 19:19:21 -0600 Subject: [PATCH 10/29] Document and clean up alarms --- extra/alarms/alarms-docs.factor | 22 ++++++++++++++++++++++ extra/alarms/alarms.factor | 24 ++++++++++++++---------- 2 files changed, 36 insertions(+), 10 deletions(-) create mode 100755 extra/alarms/alarms-docs.factor diff --git a/extra/alarms/alarms-docs.factor b/extra/alarms/alarms-docs.factor new file mode 100755 index 0000000000..a53515a68d --- /dev/null +++ b/extra/alarms/alarms-docs.factor @@ -0,0 +1,22 @@ +IN: alarms +USING: help.markup help.syntax calendar ; + +HELP: alarm +{ $class-description "An alarm. Cancel passed to " { $link cancel-alarm } "." } ; + +HELP: add-alarm +{ $values { "time" timestamp } { "frequency" "a " { $link dt } " or " { $link f } } { "quot" quotation } { "alarm" alarm } } +{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ; + +HELP: cancel-alarm +{ $values { "alarm" alarm } } +{ $description "Cancels an alarm." } +{ $errors "Throws an error if the alarm is not active." } ; + +ARTICLE: "alarms" "Alarms" +"Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread." +{ $subsection alarm } +{ $subsection add-alarm } +{ $subsection cancel-alarm } ; + +ABOUT: "alarms" diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index 03d16b892d..6a1793ee95 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -6,6 +6,8 @@ IN: alarms TUPLE: alarm time interval quot entry ; + [ - dup dup alarm-time alarms get-global heap-push* - swap alarm-entry >box - notify-alarm-thread - ] keep ; - -: cancel-alarm ( alarm -- ) - alarm-entry box> alarms get-global heap-delete ; - : alarm-expired? ( alarm now -- ? ) >r alarm-time r> <=> 0 <= ; @@ -78,3 +70,15 @@ SYMBOL: alarm-thread alarm-thread set-global ; [ init-alarms ] "alarms" add-init-hook + +PRIVATE> + +: add-alarm ( time delay quot -- alarm ) + [ + dup dup alarm-time alarms get-global heap-push* + swap alarm-entry >box + notify-alarm-thread + ] keep ; + +: cancel-alarm ( alarm -- ) + alarm-entry box> alarms get-global heap-delete ; From 929aafadac482f397748070912f32442f85e20e0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Feb 2008 19:19:26 -0600 Subject: [PATCH 11/29] Document and clean up alarms --- extra/alarms/alarms.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index 6a1793ee95..5b198fdb0d 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -73,7 +73,7 @@ SYMBOL: alarm-thread PRIVATE> -: add-alarm ( time delay quot -- alarm ) +: add-alarm ( time frequency quot -- alarm ) [ dup dup alarm-time alarms get-global heap-push* swap alarm-entry >box From 0eda22fb5a1bc41157a8cadcfad07f129986fb4b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Feb 2008 19:27:43 -0600 Subject: [PATCH 12/29] Bug fix --- extra/alarms/alarms.factor | 1 - extra/ui/tools/listener/listener.factor | 3 ++- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index 5b198fdb0d..5a48cd9a10 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -16,7 +16,6 @@ TUPLE: alarm time interval quot entry ; : ( time delay quot -- alarm ) check-alarm alarm construct-boa ; -! Global min-heap SYMBOL: alarms SYMBOL: alarm-thread diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index db26c2a150..7617b0f32d 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -6,7 +6,7 @@ kernel models namespaces parser quotations sequences ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations vocabs words -prettyprint listener debugger threads ; +prettyprint listener debugger threads boxes ; IN: ui.tools.listener TUPLE: listener-gadget input output stack ; @@ -161,6 +161,7 @@ M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? ) M: listener-gadget graft* dup delegate graft* + dup listener-gadget-input interactor-thread ?box 2drop restart-listener ; M: listener-gadget ungraft* From db55ca6408fe7927a160a0ef73f47fe7b3d8c421 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 21 Feb 2008 19:36:29 -0600 Subject: [PATCH 13/29] add misc/wordsize.c --- misc/wordsize.c | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 misc/wordsize.c diff --git a/misc/wordsize.c b/misc/wordsize.c new file mode 100644 index 0000000000..a0e7d0b9c0 --- /dev/null +++ b/misc/wordsize.c @@ -0,0 +1,8 @@ + +#include + +int main () +{ + printf("%d", 8*sizeof(void*)); + return 0; +} From 8ffc6197460f584f359fd59327f53b64cd8a7269 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 21 Feb 2008 19:36:45 -0600 Subject: [PATCH 14/29] add misc/target --- misc/target | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) create mode 100755 misc/target diff --git a/misc/target b/misc/target new file mode 100755 index 0000000000..b2b04dfc1c --- /dev/null +++ b/misc/target @@ -0,0 +1,16 @@ +#!/bin/bash + +if [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ] +then + echo macosx-ppc +elif [ `uname -s` = Darwin ] +then + echo macosx-x86-`./misc/wordsize` +elif [ \( `uname -s` = Linux \) -a \( `uname -m` = i686 \) ] +then + echo linux-x86-`./misc/wordsize` +elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ] +then + echo winnt-x86-`./misc/wordsize` +fi + From 7303efe22161645c33422ffaf27bae9f89a59079 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 21 Feb 2008 19:37:19 -0600 Subject: [PATCH 15/29] Makefile: add an 'auto' target --- Makefile | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/Makefile b/Makefile index 9776027a59..d5880921fd 100755 --- a/Makefile +++ b/Makefile @@ -158,6 +158,12 @@ factor: $(DLL_OBJS) $(EXE_OBJS) $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) +misc/wordsize: misc/wordsize.c + gcc misc/wordsize.c -o misc/wordsize + +auto: misc/wordsize + make `./misc/target` + clean: rm -f vm/*.o rm -f factor*.dll libfactor*.* From 95185cf9e12d053566083baaf6f463f954cdc4bd Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 21 Feb 2008 19:38:51 -0600 Subject: [PATCH 16/29] builder.util: add to-file --- extra/builder/util/util.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index 0e68cdbc0e..3d699d4ba8 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -98,4 +98,10 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ; : cat-n ( file n -- ) [ file-lines ] [ ] bi* maybe-tail* - [ print ] each ; \ No newline at end of file + [ print ] each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USE: prettyprint + +: to-file ( object file -- ) [ . ] with-file-writer ; \ No newline at end of file From 06511db6328658724db128b925329a430996b513 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 21 Feb 2008 20:37:18 -0600 Subject: [PATCH 17/29] Makefile: default rule builds via autodetection misc/target: output 'help' system not detected --- Makefile | 8 ++++---- misc/target | 5 +++-- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/Makefile b/Makefile index d5880921fd..60091d44ea 100755 --- a/Makefile +++ b/Makefile @@ -45,7 +45,10 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ EXE_OBJS = $(PLAF_EXE_OBJS) -default: +default: misc/wordsize + make `./misc/target` + +help: @echo "Run 'make' with one of the following parameters:" @echo "" @echo "freebsd-x86-32" @@ -161,9 +164,6 @@ factor: $(DLL_OBJS) $(EXE_OBJS) misc/wordsize: misc/wordsize.c gcc misc/wordsize.c -o misc/wordsize -auto: misc/wordsize - make `./misc/target` - clean: rm -f vm/*.o rm -f factor*.dll libfactor*.* diff --git a/misc/target b/misc/target index b2b04dfc1c..e55032784b 100755 --- a/misc/target +++ b/misc/target @@ -12,5 +12,6 @@ then elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ] then echo winnt-x86-`./misc/wordsize` -fi - +else + echo help +fi \ No newline at end of file From 666c7803f7dbc01efc8e6283f704de7c0a654c34 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Feb 2008 20:57:41 -0600 Subject: [PATCH 18/29] Fixes --- core/io/streams/c/c.factor | 2 +- core/io/thread/thread.factor | 2 +- core/threads/threads.factor | 19 +++++++----- extra/alarms/alarms-docs.factor | 2 +- extra/alarms/alarms.factor | 30 +++++++++---------- extra/calendar/calendar.factor | 8 ++++- extra/io/timeouts/timeouts-docs.factor | 3 +- extra/io/unix/backend/backend.factor | 2 +- extra/io/unix/kqueue/kqueue.factor | 3 +- extra/io/unix/select/select.factor | 2 +- extra/io/windows/ce/backend/backend.factor | 4 ++- extra/io/windows/nt/backend/backend.factor | 3 +- extra/models/models-docs.factor | 11 +++---- extra/models/models.factor | 11 +++---- extra/ui/gadgets/status-bar/status-bar.factor | 7 +++-- extra/ui/gestures/gestures.factor | 7 +++-- extra/ui/tools/interactor/interactor.factor | 5 ++-- extra/ui/tools/search/search.factor | 6 ++-- extra/windows/windows.factor | 4 +-- 19 files changed, 74 insertions(+), 57 deletions(-) mode change 100644 => 100755 extra/ui/gadgets/status-bar/status-bar.factor diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 288ab212d1..48d6e6e430 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -64,7 +64,7 @@ M: object init-stdio stdin-handle stdout-handle stdio set-global stderr-handle stderr set-global ; -M: object io-multiplex (sleep) ; +M: object io-multiplex 60 60 * 1000 * or (sleep) ; M: object "rb" fopen ; diff --git a/core/io/thread/thread.factor b/core/io/thread/thread.factor index 53ab5193c6..fe86ba9e3d 100755 --- a/core/io/thread/thread.factor +++ b/core/io/thread/thread.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.thread -USING: threads io.backend namespaces init ; +USING: threads io.backend namespaces init math ; : io-thread ( -- ) sleep-time io-multiplex yield ; diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 7a059c8fbe..2472dac52f 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -113,7 +113,7 @@ PRIVATE> PRIVATE> -: sleep-time ( -- ms ) +: sleep-time ( -- ms/f ) { { [ run-queue dlist-empty? not ] [ 0 ] } { [ sleep-queue heap-empty? ] [ f ] } @@ -134,18 +134,21 @@ PRIVATE> : yield ( -- ) [ resume ] "yield" suspend drop ; : nap ( ms/f -- ? ) - [ - >fixnum millis + [ schedule-sleep ] curry "sleep" - ] [ - [ drop ] "interrupt" - ] if* suspend ; + [ >fixnum millis + [ schedule-sleep ] curry "sleep" ] + [ [ drop ] "interrupt" ] if* + suspend ; : sleep ( ms -- ) nap [ "Sleep interrupted" throw ] when ; : interrupt ( thread -- ) - dup thread-sleep-entry [ sleep-queue heap-delete ] when* - t swap resume-with ; + dup self eq? [ + drop + ] [ + dup thread-sleep-entry [ sleep-queue heap-delete ] when* + f over set-thread-sleep-entry + t swap resume-with + ] if ; : (spawn) ( thread -- ) [ diff --git a/extra/alarms/alarms-docs.factor b/extra/alarms/alarms-docs.factor index a53515a68d..6591e61623 100755 --- a/extra/alarms/alarms-docs.factor +++ b/extra/alarms/alarms-docs.factor @@ -1,5 +1,5 @@ IN: alarms -USING: help.markup help.syntax calendar ; +USING: help.markup help.syntax calendar quotations ; HELP: alarm { $class-description "An alarm. Cancel passed to " { $link cancel-alarm } "." } ; diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index 5a48cd9a10..165a081faa 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -8,6 +8,12 @@ TUPLE: alarm time interval quot entry ; ( time delay quot -- alarm ) check-alarm alarm construct-boa ; -SYMBOL: alarms -SYMBOL: alarm-thread - -: notify-alarm-thread ( -- ) - alarm-thread get-global interrupt ; +: register-alarm ( alarm -- ) + dup dup alarm-time alarms get-global heap-push* + swap alarm-entry >box + notify-alarm-thread ; : alarm-expired? ( alarm now -- ? ) >r alarm-time r> <=> 0 <= ; @@ -28,7 +33,7 @@ SYMBOL: alarm-thread : reschedule-alarm ( alarm -- ) dup alarm-time over alarm-interval +dt over set-alarm-time - add-alarm drop ; + register-alarm ; : call-alarm ( alarm -- ) dup alarm-quot try @@ -52,10 +57,9 @@ SYMBOL: alarm-thread : next-alarm ( alarms -- ms ) dup heap-empty? - [ drop f ] [ - heap-peek drop alarm-time now - [ timestamp>unix-time ] 2apply [-] 1000 * - ] if ; + [ drop f ] + [ heap-peek drop alarm-time now timestamp- 1000 * 0 max ] + if ; : alarm-thread-loop ( -- ) alarms get-global @@ -73,11 +77,7 @@ SYMBOL: alarm-thread PRIVATE> : add-alarm ( time frequency quot -- alarm ) - [ - dup dup alarm-time alarms get-global heap-push* - swap alarm-entry >box - notify-alarm-thread - ] keep ; + [ register-alarm ] keep ; : cancel-alarm ( alarm -- ) alarm-entry box> alarms get-global heap-delete ; diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 86dc973a9a..165f35bce2 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -223,7 +223,13 @@ M: timestamp <=> ( ts1 ts2 -- n ) [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ; : unix-1970 ( -- timestamp ) - 1970 1 1 0 0 0 0 ; foldable + 1970 1 1 0 0 0 0 ; + +: millis>timestamp ( n -- timestamp ) + >r unix-1970 r> 1000 /f seconds +dt ; + +: timestamp>millis ( timestamp -- n ) + unix-1970 timestamp- 1000 * >integer ; : unix-time>timestamp ( n -- timestamp ) >r unix-1970 r> seconds +dt ; diff --git a/extra/io/timeouts/timeouts-docs.factor b/extra/io/timeouts/timeouts-docs.factor index c03520bb56..347c57a0d6 100755 --- a/extra/io/timeouts/timeouts-docs.factor +++ b/extra/io/timeouts/timeouts-docs.factor @@ -25,7 +25,6 @@ ARTICLE: "io.timeouts" "I/O timeout protocol" { $subsection timed-out } "A combinator to be used in operations which can time out:" { $subsection with-timeout } -{ $see-also "stream-protocol" "io.launcher" } -; +{ $see-also "stream-protocol" "io.launcher" } ; ABOUT: "io.timeouts" diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index f31c67e0eb..fe2f63e99a 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -178,7 +178,7 @@ M: write-task do-io-task M: port port-flush ( port -- ) dup buffer-empty? [ drop ] [ (wait-to-write) ] if ; -M: unix-io io-multiplex ( ms -- ) +M: unix-io io-multiplex ( ms/f -- ) mx get-global wait-for-events ; M: unix-io init-stdio ( -- ) diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index 04bb70d57d..7b67a9d468 100755 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -66,7 +66,8 @@ M: kqueue-mx unregister-io-task ( task mx -- ) [ over kqueue-mx-events kevent-nth handle-kevent ] with each ; M: kqueue-mx wait-for-events ( ms mx -- ) - swap make-timespec dupd wait-kevent handle-kevents ; + swap dup [ make-timespec ] when + dupd wait-kevent handle-kevents ; : make-proc-kevent ( pid -- kevent ) "kevent" diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index 9827d4d54f..77a20beb42 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -49,7 +49,7 @@ TUPLE: select-mx read-fdset write-fdset ; f ; M: select-mx wait-for-events ( ms mx -- ) - swap >r dup init-fdsets r> make-timeval + swap >r dup init-fdsets r> dup [ make-timeval ] when select multiplexer-error dup read-fdset/tasks pick handle-fdset dup write-fdset/tasks rot handle-fdset ; diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index e90a9f16e2..d92b4db77c 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -7,7 +7,9 @@ IN: io.windows.ce.backend : port-errored ( port -- ) win32-error-string swap set-port-error ; -M: windows-ce-io io-multiplex ( ms -- ) (sleep) ; +M: windows-ce-io io-multiplex ( ms -- ) + 60 60 * 1000 * or (sleep) ; + M: windows-ce-io add-completion ( handle -- ) drop ; GENERIC: wince-read ( port port-handle -- ) diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 50b199b3bd..10e55ed5f2 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -57,7 +57,8 @@ M: windows-nt-io add-completion ( handle -- ) ] "I/O" suspend 3drop ; : wait-for-overlapped ( ms -- overlapped ? ) - >r master-completion-port get-global r> ! port ms + >r master-completion-port get-global + r> INFINITE or ! timeout 0 ! bytes f ! key f ! overlapped diff --git a/extra/models/models-docs.factor b/extra/models/models-docs.factor index 92ea6ced95..ce86905b9f 100755 --- a/extra/models/models-docs.factor +++ b/extra/models/models-docs.factor @@ -1,4 +1,5 @@ -USING: help.syntax help.markup kernel math classes tuples ; +USING: help.syntax help.markup kernel math classes tuples +calendar ; IN: models HELP: model @@ -142,18 +143,18 @@ HELP: delay { $examples "The following code displays a sliders and a label which is updated half a second after the slider stops changing:" { $code - "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes ;" + "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes calendar ;" ": " " 0 0 0 100 500 over set-slider-max ;" " dup gadget." - "gadget-model 500 [ number>string ] " + "gadget-model 1/2 seconds [ number>string ] " " gadget." } } ; HELP: -{ $values { "model" model } { "timeout" "a positive integer" } { "delay" delay } } -{ $description "Creates a new instance of " { $link delay } ". A timer of " { $snippet "timeout" } " milliseconds must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." } +{ $values { "model" model } { "timeout" dt } { "delay" delay } } +{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." } { $examples "See the example in the documentation for " { $link delay } "." } ; HELP: range-value diff --git a/extra/models/models.factor b/extra/models/models.factor index 6d2b0907c5..f9d3f57123 100755 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: generic kernel math sequences arrays assocs alarms ; +USING: generic kernel math sequences arrays assocs alarms +calendar ; IN: models TUPLE: model value connections dependencies ref locked? ; @@ -186,14 +187,14 @@ TUPLE: delay model timeout alarm ; [ add-dependency ] keep ; : cancel-delay ( delay -- ) - delay-model-alarm [ cancel-alarm ] when* ; + delay-alarm [ cancel-alarm ] when* ; : start-delay ( delay -- ) - now over delay-model-timeout dt+ f + now over delay-timeout +dt f pick [ f over set-delay-alarm update-delay-model ] curry - add-alarm swap set-delay-model-alarm ; + add-alarm swap set-delay-alarm ; -M: delay model-changed nip start-delay ; +M: delay model-changed nip dup cancel-delay start-delay ; M: delay model-activated update-delay-model ; diff --git a/extra/ui/gadgets/status-bar/status-bar.factor b/extra/ui/gadgets/status-bar/status-bar.factor old mode 100644 new mode 100755 index c5508e1891..b528d6739c --- a/extra/ui/gadgets/status-bar/status-bar.factor +++ b/extra/ui/gadgets/status-bar/status-bar.factor @@ -1,11 +1,12 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: models sequences ui.gadgets.labels ui.gadgets.theme -ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel ; +ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel +calendar ; IN: ui.gadgets.status-bar : ( model -- gadget ) - 100 [ "" like ] + 1/10 seconds [ "" like ] dup reverse-video-theme t over set-gadget-root? ; diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index 2d3e8f6835..e9a24d702f 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs kernel math models namespaces sequences words strings system hashtables math.parser -math.vectors tuples classes ui.gadgets combinators.lib ; +math.vectors tuples classes ui.gadgets combinators.lib boxes +calendar alarms ; IN: ui.gestures : set-gestures ( class hash -- ) "gestures" set-word-prop ; @@ -113,7 +114,7 @@ SYMBOL: drag-timer : start-drag-timer ( -- ) hand-buttons get-global empty? [ - now 300 milliseconds dt+ 100 milliseconds + now 300 milliseconds +dt 100 milliseconds [ drag-gesture ] add-alarm drag-timer get-global >box ] when ; diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index a7b1568cf9..3c9809f343 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -6,7 +6,7 @@ math.vectors models namespaces parser prettyprint quotations sequences sequences.lib strings threads listener tuples ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds ui.gestures -definitions boxes ; +definitions boxes calendar ; IN: ui.tools.interactor TUPLE: interactor @@ -29,7 +29,8 @@ help ; ] if ; : init-caret-help ( interactor -- ) - dup editor-caret 100 swap set-interactor-help ; + dup editor-caret 1/3 seconds + swap set-interactor-help ; : init-interactor-history ( interactor -- ) V{ } clone swap set-interactor-history ; diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor index 4bf89d03d1..978ca295ca 100755 --- a/extra/ui/tools/search/search.factor +++ b/extra/ui/tools/search/search.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs ui.tools.interactor ui.tools.listener ui.tools.workspace help help.topics io.files io.styles kernel @@ -7,7 +7,7 @@ source-files strings tools.completion tools.crossref tuples ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations vocabs words vocabs.loader -tools.browser unicode.case ; +tools.browser unicode.case calendar ; IN: ui.tools.search TUPLE: live-search field list ; @@ -45,7 +45,7 @@ search-field H{ } set-gestures : ( producer -- model ) - >r g live-search-field gadget-model 200 + >r g live-search-field gadget-model 1/5 seconds [ "\n" join ] r> append ; : ( seq limited? presenter -- gadget ) diff --git a/extra/windows/windows.factor b/extra/windows/windows.factor index e07c504781..600c0a4039 100755 --- a/extra/windows/windows.factor +++ b/extra/windows/windows.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.syntax alien.c-types arrays combinators -io io.nonblocking kernel math namespaces parser prettyprint -sequences windows.errors windows.types windows.kernel32 words ; +kernel math namespaces parser prettyprint sequences +windows.errors windows.types windows.kernel32 words ; IN: windows : lo-word ( wparam -- lo ) *short ; inline From 1ef1d41ab1994f6562cb989eaab4b916b3453b19 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 21 Feb 2008 21:59:05 -0600 Subject: [PATCH 19/29] remove cp_dir --- cp_dir | 5 ----- 1 file changed, 5 deletions(-) delete mode 100755 cp_dir diff --git a/cp_dir b/cp_dir deleted file mode 100755 index 76c8a8f03b..0000000000 --- a/cp_dir +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/sh - -echo $1 -mkdir -p "`dirname \"$2\"`" -cp "$1" "$2" From b2cc6914b6227c197bc5425ca1161eeea68d2fc2 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 21 Feb 2008 22:07:22 -0600 Subject: [PATCH 20/29] .gitignore: temp directory --- .gitignore | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/.gitignore b/.gitignore index 897825c826..c4bb6b7937 100644 --- a/.gitignore +++ b/.gitignore @@ -15,5 +15,4 @@ factor .gdb_history *.*.marks .*.swp -reverse-complement-in.txt -reverse-complement-out.txt +temp \ No newline at end of file From 41ca620271b0fdd5db6ae9e6322e65adc64ef6a9 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 21 Feb 2008 22:08:03 -0600 Subject: [PATCH 21/29] io.files: temp-file --- core/io/files/files.factor | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 1824a47867..108ace4393 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -154,3 +154,11 @@ M: pathname <=> [ pathname-string ] compare ; : with-file-appender ( path quot -- ) >r r> with-stream ; inline + +: temp-dir ( -- path ) + "temp" resource-path + dup exists? not + [ dup make-directory ] + when ; + +: temp-file ( name -- path ) temp-dir swap path+ ; \ No newline at end of file From 09e5564435e2d67834144e74c98746f81d3389ec Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 21 Feb 2008 22:08:51 -0600 Subject: [PATCH 22/29] Use temp-file in a few tests and benchmarks --- core/io/streams/c/c-tests.factor | 4 ++-- extra/benchmark/mandel/mandel.factor | 2 +- extra/benchmark/raytracer/raytracer.factor | 2 +- extra/io/unix/unix-tests.factor | 6 +++--- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 5ace929ceb..16b78c2192 100755 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -2,9 +2,9 @@ USING: tools.test io.files io io.streams.c ; IN: temporary [ "hello world" ] [ - "test.txt" resource-path [ + "test.txt" temp-file [ "hello world" write ] with-file-writer - "test.txt" resource-path "rb" fopen contents + "test.txt" temp-file "rb" fopen contents ] unit-test diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index 230fb2f889..0da4785785 100755 --- a/extra/benchmark/mandel/mandel.factor +++ b/extra/benchmark/mandel/mandel.factor @@ -65,7 +65,7 @@ SYMBOL: cols ] with-scope ; : mandel-main ( -- ) - "mandel.ppm" resource-path + "mandel.ppm" temp-file [ mandel write ] with-file-writer ; MAIN: mandel-main diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 8f2badc95f..ddfd0ed6dd 100644 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -170,7 +170,7 @@ DEFER: create ( level c r -- scene ) ] "" make ; : raytracer-main - "raytracer.pnm" resource-path + "raytracer.pnm" temp-file [ run write ] with-file-writer ; MAIN: raytracer-main diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index 515077f22b..6eb0b78955 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -38,8 +38,8 @@ yield "unix-domain-datagram-test" resource-path delete-file ] ignore-errors -: server-addr "unix-domain-datagram-test" resource-path ; -: client-addr "unix-domain-datagram-test-2" resource-path ; +: server-addr "unix-domain-datagram-test" temp-file ; +: client-addr "unix-domain-datagram-test-2" temp-file ; [ [ @@ -112,7 +112,7 @@ client-addr "unix-domain-datagram-test-3" resource-path delete-file ] ignore-errors -"unix-domain-datagram-test-2" resource-path delete-file +"unix-domain-datagram-test-2" temp-file delete-file [ ] [ client-addr "d" set ] unit-test From 9ead707c5b43961e7598a99e7715ff515c377f8e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 21 Feb 2008 22:14:08 -0600 Subject: [PATCH 23/29] benchmark.reverse-complement: use temp-file --- .../benchmark/reverse-complement/reverse-complement.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/extra/benchmark/reverse-complement/reverse-complement.factor b/extra/benchmark/reverse-complement/reverse-complement.factor index 0771b756bf..cf4143d533 100755 --- a/extra/benchmark/reverse-complement/reverse-complement.factor +++ b/extra/benchmark/reverse-complement/reverse-complement.factor @@ -41,12 +41,10 @@ HINTS: do-line vector string ; ] with-disposal ; : reverse-complement-in - "extra/benchmark/reverse-complement/reverse-complement-in.txt" - resource-path ; + "reverse-complement-in.txt" temp-file ; : reverse-complement-out - "extra/benchmark/reverse-complement/reverse-complement-out.txt" - resource-path ; + "reverse-complement-out.txt" temp-file ; : reverse-complement-main ( -- ) reverse-complement-in From 31c2659828628fe2af9a57a53a7b6ff0f83ee5d3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 21 Feb 2008 22:16:10 -0600 Subject: [PATCH 24/29] .gitignore: logs, work, etc --- .gitignore | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index c4bb6b7937..19ace1f500 100644 --- a/.gitignore +++ b/.gitignore @@ -15,4 +15,7 @@ factor .gdb_history *.*.marks .*.swp -temp \ No newline at end of file +temp +logs +work +misc/wordsize \ No newline at end of file From 727f91409d6b01ddc3de44d30c377488fa60481e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Feb 2008 23:47:06 -0600 Subject: [PATCH 25/29] Split off concurrency.mailboxes, add timeout support to promises, locks, mailboxes, semaphores, count-downs --- core/layouts/layouts.factor | 4 + core/math/integers/integers-docs.factor | 1 + core/math/integers/integers.factor | 1 + core/math/math.factor | 1 + core/threads/threads.factor | 20 ++- extra/alarms/alarms-docs.factor | 7 +- extra/alarms/alarms.factor | 15 ++- extra/calendar/calendar.factor | 6 +- .../combinators/combinators-tests.factor | 2 +- .../concurrency/conditions/conditions.factor | 23 +++- extra/concurrency/futures/futures.factor | 6 +- extra/concurrency/locks/locks-tests.factor | 51 +++++--- extra/concurrency/locks/locks.factor | 19 ++- .../mailboxes/mailboxes-docs.factor | 75 +++++++++++ .../mailboxes/mailboxes-tests.factor | 40 ++++++ extra/concurrency/mailboxes/mailboxes.factor | 76 +++++++++++ .../messaging/messaging-docs.factor | 81 +----------- .../messaging/messaging-tests.factor | 42 +----- extra/concurrency/messaging/messaging.factor | 122 ++++-------------- extra/concurrency/promises/promises.factor | 6 +- .../semaphores/semaphores-docs.factor | 21 ++- .../concurrency/semaphores/semaphores.factor | 20 +-- extra/help/handbook/handbook.factor | 1 + extra/http/client/client.factor | 4 +- extra/http/server/server.factor | 2 +- extra/io/timeouts/timeouts.factor | 2 +- extra/math/ranges/ranges.factor | 4 - extra/models/models.factor | 6 +- extra/ui/gadgets/buttons/buttons.factor | 3 +- extra/ui/gestures/gestures.factor | 6 +- 30 files changed, 382 insertions(+), 285 deletions(-) create mode 100755 extra/concurrency/mailboxes/mailboxes-docs.factor create mode 100755 extra/concurrency/mailboxes/mailboxes-tests.factor create mode 100755 extra/concurrency/mailboxes/mailboxes.factor mode change 100644 => 100755 extra/math/ranges/ranges.factor diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index 2f8b158bbf..cba3532d9f 100755 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -32,3 +32,7 @@ SYMBOL: type-numbers : most-negative-fixnum ( -- n ) first-bignum neg ; + +M: real >integer + dup most-negative-fixnum most-positive-fixnum between? + [ >fixnum ] [ >bignum ] if ; diff --git a/core/math/integers/integers-docs.factor b/core/math/integers/integers-docs.factor index aa716c3197..056e19e1de 100755 --- a/core/math/integers/integers-docs.factor +++ b/core/math/integers/integers-docs.factor @@ -14,6 +14,7 @@ $nl { $subsection fixnum? } { $subsection bignum? } { $subsection >fixnum } +{ $subsection >integer } { $subsection >bignum } { $see-also "prettyprint-numbers" "modular-arithmetic" "bitwise-arithmetic" "integer-functions" "syntax-integers" } ; diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 59a4dff8de..011af6342e 100755 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -6,6 +6,7 @@ IN: math.integers.private M: integer numerator ; M: integer denominator drop 1 ; +M: integer >integer ; M: fixnum >fixnum ; M: fixnum >bignum fixnum>bignum ; diff --git a/core/math/math.factor b/core/math/math.factor index 8b48e49f97..1d034aad49 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -5,6 +5,7 @@ IN: math GENERIC: >fixnum ( x -- y ) foldable GENERIC: >bignum ( x -- y ) foldable +GENERIC: >integer ( x -- y ) foldable GENERIC: >float ( x -- y ) foldable MATH: number= ( x y -- ? ) foldable diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 2472dac52f..2ba5179c1c 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -133,12 +133,22 @@ PRIVATE> : yield ( -- ) [ resume ] "yield" suspend drop ; -: nap ( ms/f -- ? ) - [ >fixnum millis + [ schedule-sleep ] curry "sleep" ] - [ [ drop ] "interrupt" ] if* - suspend ; +GENERIC: nap-until ( time -- ? ) -: sleep ( ms -- ) +M: integer nap-until [ schedule-sleep ] curry "sleep" suspend ; + +M: f nap-until drop [ drop ] "interrupt" suspend ; + +GENERIC: nap ( time -- ? ) + +M: real nap millis + >integer nap-until ; + +M: f nap nap-until ; + +: sleep-until ( time -- ) + nap-until [ "Sleep interrupted" throw ] when ; + +: sleep ( time -- ) nap [ "Sleep interrupted" throw ] when ; : interrupt ( thread -- ) diff --git a/extra/alarms/alarms-docs.factor b/extra/alarms/alarms-docs.factor index 6591e61623..d0fcc7bf66 100755 --- a/extra/alarms/alarms-docs.factor +++ b/extra/alarms/alarms-docs.factor @@ -5,9 +5,13 @@ HELP: alarm { $class-description "An alarm. Cancel passed to " { $link cancel-alarm } "." } ; HELP: add-alarm -{ $values { "time" timestamp } { "frequency" "a " { $link dt } " or " { $link f } } { "quot" quotation } { "alarm" alarm } } +{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link dt } " or " { $link f } } { "alarm" alarm } } { $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ; +HELP: later +{ $values { "quot" quotation } { "time" dt } { "alarm" alarm } } +{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ; + HELP: cancel-alarm { $values { "alarm" alarm } } { $description "Cancels an alarm." } @@ -17,6 +21,7 @@ ARTICLE: "alarms" "Alarms" "Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread." { $subsection alarm } { $subsection add-alarm } +{ $subsection later } { $subsection cancel-alarm } ; ABOUT: "alarms" diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index 165a081faa..7cac654b60 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -4,7 +4,7 @@ USING: arrays calendar combinators generic init kernel math namespaces sequences heaps boxes threads debugger quotations ; IN: alarms -TUPLE: alarm time interval quot entry ; +TUPLE: alarm quot time interval entry ; ( time delay quot -- alarm ) +: ( quot time frequency -- alarm ) check-alarm alarm construct-boa ; : register-alarm ( alarm -- ) @@ -76,8 +76,11 @@ SYMBOL: alarm-thread PRIVATE> -: add-alarm ( time frequency quot -- alarm ) +: add-alarm ( quot time frequency -- alarm ) [ register-alarm ] keep ; +: later ( quot dt -- alarm ) + from-now f add-alarm ; + : cancel-alarm ( alarm -- ) alarm-entry box> alarms get-global heap-delete ; diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 165f35bce2..d1d7246a58 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -5,7 +5,7 @@ USING: arrays hashtables io io.streams.string kernel math math.vectors math.functions math.parser namespaces sequences strings tuples system debugger combinators vocabs.loader calendar.backend structs alien.c-types math.vectors -math.ranges shuffle ; +shuffle threads ; IN: calendar TUPLE: timestamp year month day hour minute second gmt-offset ; @@ -473,6 +473,10 @@ M: timestamp year. ( timestamp -- ) : seconds-since-midnight ( timestamp -- x ) dup beginning-of-day timestamp- ; +M: timestamp nap-until timestamp>millis nap-until ; + +M: dt nap from-now nap-until ; + { { [ unix? ] [ "calendar.unix" ] } { [ windows? ] [ "calendar.windows" ] } diff --git a/extra/concurrency/combinators/combinators-tests.factor b/extra/concurrency/combinators/combinators-tests.factor index ed59034835..831dad6b56 100755 --- a/extra/concurrency/combinators/combinators-tests.factor +++ b/extra/concurrency/combinators/combinators-tests.factor @@ -1,6 +1,6 @@ IN: temporary USING: concurrency.combinators tools.test random kernel math -concurrency.messaging threads sequences ; +concurrency.mailboxes threads sequences ; [ [ drop ] parallel-each ] must-infer [ [ ] parallel-map ] must-infer diff --git a/extra/concurrency/conditions/conditions.factor b/extra/concurrency/conditions/conditions.factor index 8126900dbc..359ceaa9ae 100755 --- a/extra/concurrency/conditions/conditions.factor +++ b/extra/concurrency/conditions/conditions.factor @@ -1,14 +1,27 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: dlists threads kernel arrays sequences ; +USING: dlists dlists.private threads kernel arrays sequences +alarms ; IN: concurrency.conditions : notify-1 ( dlist -- ) - dup dlist-empty? - [ drop ] [ pop-back second resume-now ] if ; + dup dlist-empty? [ drop ] [ pop-back resume-now ] if ; : notify-all ( dlist -- ) - [ second resume-now ] dlist-slurp yield ; + [ resume-now ] dlist-slurp yield ; + +: queue-timeout ( queue timeout -- alarm ) + #! Add an alarm which removes the current thread from the + #! queue, and resumes it, passing it a value of t. + >r self over push-front* [ + tuck delete-node + dlist-node-obj t swap resume-with + ] 2curry r> later ; : wait ( queue timeout status -- ) - >r [ 2array swap push-front ] r> suspend 3drop ; inline + over [ + >r queue-timeout [ drop ] r> suspend + [ "Timeout" throw ] [ cancel-alarm ] if + ] [ + >r drop [ push-front ] curry r> suspend drop + ] if ; diff --git a/extra/concurrency/futures/futures.factor b/extra/concurrency/futures/futures.factor index 0a05d2d78e..85f1ba44a0 100755 --- a/extra/concurrency/futures/futures.factor +++ b/extra/concurrency/futures/futures.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: concurrency.promises concurrency.messaging kernel arrays +USING: concurrency.promises concurrency.mailboxes kernel arrays continuations ; IN: concurrency.futures @@ -11,7 +11,7 @@ IN: concurrency.futures ] keep ; inline : ?future-timeout ( future timeout -- value ) - ?promise-timeout ; + ?promise-timeout ?linked ; : ?future ( future -- value ) - ?promise ; + ?promise ?linked ; diff --git a/extra/concurrency/locks/locks-tests.factor b/extra/concurrency/locks/locks-tests.factor index 4c1d280cd6..8ebf6856a9 100755 --- a/extra/concurrency/locks/locks-tests.factor +++ b/extra/concurrency/locks/locks-tests.factor @@ -1,6 +1,7 @@ IN: temporary USING: tools.test concurrency.locks concurrency.count-downs -locals kernel threads sequences ; +concurrency.messaging concurrency.mailboxes locals kernel +threads sequences calendar ; :: lock-test-0 | | [let | v [ V{ } clone ] @@ -32,7 +33,7 @@ locals kernel threads sequences ; c [ 2 ] | [ - l f [ + l [ yield 1 v push yield @@ -42,7 +43,7 @@ locals kernel threads sequences ; ] "Lock test 1" spawn drop [ - l f [ + l [ yield 3 v push yield @@ -59,8 +60,8 @@ locals kernel threads sequences ; [ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test [ 3 ] [ - dup f [ - f [ + dup [ + [ 3 ] with-lock ] with-lock @@ -68,15 +69,15 @@ locals kernel threads sequences ; [ ] [ drop ] unit-test -[ ] [ f [ ] with-read-lock ] unit-test +[ ] [ [ ] with-read-lock ] unit-test -[ ] [ dup f [ f [ ] with-read-lock ] with-read-lock ] unit-test +[ ] [ dup [ [ ] with-read-lock ] with-read-lock ] unit-test -[ ] [ f [ ] with-write-lock ] unit-test +[ ] [ [ ] with-write-lock ] unit-test -[ ] [ dup f [ f [ ] with-write-lock ] with-write-lock ] unit-test +[ ] [ dup [ [ ] with-write-lock ] with-write-lock ] unit-test -[ ] [ dup f [ f [ ] with-read-lock ] with-write-lock ] unit-test +[ ] [ dup [ [ ] with-read-lock ] with-write-lock ] unit-test :: rw-lock-test-1 | | [let | l [ ] @@ -86,7 +87,7 @@ locals kernel threads sequences ; v [ V{ } clone ] | [ - l f [ + l [ 1 v push c count-down yield @@ -97,7 +98,7 @@ locals kernel threads sequences ; [ c await - l f [ + l [ 4 v push 1000 sleep 5 v push @@ -107,7 +108,7 @@ locals kernel threads sequences ; [ c await - l f [ + l [ 2 v push c' count-down ] with-read-lock @@ -116,7 +117,7 @@ locals kernel threads sequences ; [ c' await - l f [ + l [ 6 v push ] with-write-lock c'' count-down @@ -135,7 +136,7 @@ locals kernel threads sequences ; v [ V{ } clone ] | [ - l f [ + l [ 1 v push c count-down 1000 sleep @@ -146,7 +147,7 @@ locals kernel threads sequences ; [ c await - l f [ + l [ 3 v push ] with-read-lock c' count-down @@ -157,3 +158,21 @@ locals kernel threads sequences ; ] ; [ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test + +! Test lock timeouts +:: lock-timeout-test | | + [let | l [ ] | + [ + l [ 1 seconds sleep ] with-lock + ] "Lock holder" spawn drop + + [ + l 1/10 seconds [ ] with-lock-timeout + ] "Lock timeout-er" spawn-linked drop + + receive + ] ; + +[ lock-timeout-test ] [ + linked-thread thread-name "Lock timeout-er" = +] must-fail-with diff --git a/extra/concurrency/locks/locks.factor b/extra/concurrency/locks/locks.factor index f4138a0a76..ea442612b1 100755 --- a/extra/concurrency/locks/locks.factor +++ b/extra/concurrency/locks/locks.factor @@ -25,15 +25,15 @@ TUPLE: lock threads owner reentrant? ; lock-threads notify-1 ; : do-lock ( lock timeout quot acquire release -- ) - >r swap compose pick >r 2curry r> r> curry [ ] cleanup ; - inline + >r >r pick rot r> call ! use up timeout acquire + swap r> curry [ ] cleanup ; inline : (with-lock) ( lock timeout quot -- ) [ acquire-lock ] [ release-lock ] do-lock ; inline PRIVATE> -: with-lock ( lock timeout quot -- ) +: with-lock-timeout ( lock timeout quot -- ) pick lock-reentrant? [ pick lock-owner self eq? [ 2nip call @@ -44,6 +44,9 @@ PRIVATE> (with-lock) ] if ; inline +: with-lock ( lock quot -- ) + f swap with-lock-timeout ; inline + ! Many-reader/single-writer locks TUPLE: rw-lock readers writers reader# writer ; @@ -79,12 +82,18 @@ TUPLE: rw-lock readers writers reader# writer ; PRIVATE> -: with-read-lock ( lock timeout quot -- ) +: with-read-lock-timeout ( lock timeout quot -- ) [ [ acquire-read-lock ] [ release-read-lock ] do-lock ] do-reentrant-rw-lock ; inline -: with-write-lock ( lock timeout quot -- ) +: with-read-lock ( lock quot -- ) + f swap with-read-lock-timeout ; inline + +: with-write-lock-timeout ( lock timeout quot -- ) [ [ acquire-write-lock ] [ release-write-lock ] do-lock ] do-reentrant-rw-lock ; inline + +: with-write-lock ( lock quot -- ) + f swap with-write-lock-timeout ; inline diff --git a/extra/concurrency/mailboxes/mailboxes-docs.factor b/extra/concurrency/mailboxes/mailboxes-docs.factor new file mode 100755 index 0000000000..4937ef1fb9 --- /dev/null +++ b/extra/concurrency/mailboxes/mailboxes-docs.factor @@ -0,0 +1,75 @@ +USING: help.markup help.syntax kernel arrays ; +IN: concurrency.mailboxes + +HELP: +{ $values { "mailbox" mailbox } } +{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to thread the get operation." } ; + +HELP: mailbox-empty? +{ $values { "mailbox" mailbox } + { "bool" "a boolean" } +} +{ $description "Return true if the mailbox is empty." } ; + +HELP: mailbox-put +{ $values { "obj" object } + { "mailbox" mailbox } +} +{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ; + +HELP: block-unless-pred +{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } + { "mailbox" mailbox } + { "timeout" "a timeout in milliseconds, or " { $link f } } +} +{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ; + +HELP: block-if-empty +{ $values { "mailbox" mailbox } + { "timeout" "a timeout in milliseconds, or " { $link f } } +} +{ $description "Block the thread if the mailbox is empty." } ; + +HELP: mailbox-get +{ $values { "mailbox" mailbox } + { "obj" object } +} +{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } ; + +HELP: mailbox-get-all +{ $values { "mailbox" mailbox } + { "array" array } +} +{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } ; + +HELP: while-mailbox-empty +{ $values { "mailbox" mailbox } + { "quot" "a quotation with stack effect " { $snippet "( -- )" } } +} +{ $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 } + { "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." } ; + + +ARTICLE: "concurrency.mailboxes" "Mailboxes" +"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error." +{ $subsection mailbox } +{ $subsection } +"Removing the first element:" +{ $subsection mailbox-get } +{ $subsection mailbox-get-timeout } +"Removing the first element matching a predicate:" +{ $subsection mailbox-get? } +{ $subsection mailbox-get-timeout? } +"Emptying out a mailbox:" +{ $subsection mailbox-get-all } +"Adding an element:" +{ $subsection mailbox-put } +"Testing if a mailbox is empty:" +{ $subsection mailbox-empty? } +{ $subsection while-mailbox-empty } ; diff --git a/extra/concurrency/mailboxes/mailboxes-tests.factor b/extra/concurrency/mailboxes/mailboxes-tests.factor new file mode 100755 index 0000000000..4541d06a5a --- /dev/null +++ b/extra/concurrency/mailboxes/mailboxes-tests.factor @@ -0,0 +1,40 @@ +IN: temporary +USING: concurrency.mailboxes vectors sequences threads +tools.test math kernel strings ; + +[ V{ 1 2 3 } ] [ + 0 + + [ mailbox-get swap push ] in-thread + [ mailbox-get swap push ] in-thread + [ mailbox-get swap push ] in-thread + 1 over mailbox-put + 2 over mailbox-put + 3 swap mailbox-put +] unit-test + +[ 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 + 1 over mailbox-put + 2 over mailbox-put + 3 swap mailbox-put +] unit-test + +[ 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 + 1 over mailbox-put + "junk" over mailbox-put + [ 456 ] over mailbox-put + 3 over mailbox-put + "junk2" over mailbox-put + mailbox-get +] unit-test diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor new file mode 100755 index 0000000000..e5f12d5507 --- /dev/null +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -0,0 +1,76 @@ +! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: concurrency.mailboxes +USING: dlists threads sequences continuations +namespaces random math quotations words kernel arrays assocs +init system concurrency.conditions ; + +TUPLE: mailbox threads data ; + +: ( -- mailbox ) + mailbox construct-boa ; + +: mailbox-empty? ( mailbox -- bool ) + mailbox-data dlist-empty? ; + +: mailbox-put ( obj mailbox -- ) + [ mailbox-data push-front ] keep + mailbox-threads notify-all ; + +: block-unless-pred ( pred mailbox timeout -- ) + 2over mailbox-data dlist-contains? [ + 3drop + ] [ + 2dup >r mailbox-threads r> "mailbox" wait + block-unless-pred + ] if ; inline + +: block-if-empty ( mailbox timeout -- mailbox ) + over mailbox-empty? [ + 2dup >r mailbox-threads r> "mailbox" wait + block-if-empty + ] [ + drop + ] if ; + +: mailbox-peek ( mailbox -- obj ) + mailbox-data peek-back ; + +: mailbox-get-timeout ( mailbox timeout -- obj ) + block-if-empty mailbox-data pop-back ; + +: mailbox-get ( mailbox -- obj ) + f mailbox-get-timeout ; + +: mailbox-get-all-timeout ( mailbox timeout -- array ) + block-if-empty + [ dup mailbox-empty? ] + [ dup mailbox-data pop-back ] + [ ] unfold nip ; + +: mailbox-get-all ( mailbox -- array ) + f mailbox-get-all-timeout ; + +: while-mailbox-empty ( mailbox quot -- ) + over mailbox-empty? [ + dup >r swap slip r> while-mailbox-empty + ] [ + 2drop + ] if ; inline + +: mailbox-get-timeout? ( pred mailbox timeout -- obj ) + [ block-unless-pred ] 3keep drop + mailbox-data delete-node-if ; inline + +: mailbox-get? ( pred mailbox -- obj ) + f mailbox-get-timeout? ; inline + +TUPLE: linked error thread ; + +C: linked + +: ?linked dup linked? [ rethrow ] when ; + +: spawn-linked-to ( quot name mailbox -- thread ) + [ >r r> mailbox-put ] curry + [ (spawn) ] keep ; diff --git a/extra/concurrency/messaging/messaging-docs.factor b/extra/concurrency/messaging/messaging-docs.factor index 45bf2006e0..bee80fd357 100755 --- a/extra/concurrency/messaging/messaging-docs.factor +++ b/extra/concurrency/messaging/messaging-docs.factor @@ -4,70 +4,6 @@ USING: help.syntax help.markup concurrency.messaging.private threads kernel arrays quotations ; IN: concurrency.messaging -HELP: -{ $values { "mailbox" mailbox } -} -{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to thread the get operation." } -{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; - -HELP: mailbox-empty? -{ $values { "mailbox" mailbox } - { "bool" "a boolean" } -} -{ $description "Return true if the mailbox is empty." } -{ $see-also mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; - -HELP: mailbox-put -{ $values { "obj" object } - { "mailbox" mailbox } -} -{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } -{ $see-also mailbox-empty? mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; - -HELP: block-unless-pred -{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } - { "mailbox" mailbox } - { "timeout" "a timeout in milliseconds, or " { $link f } } -} -{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } -{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; - -HELP: block-if-empty -{ $values { "mailbox" mailbox } - { "timeout" "a timeout in milliseconds, or " { $link f } } -} -{ $description "Block the thread if the mailbox is empty." } -{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; - -HELP: mailbox-get -{ $values { "mailbox" mailbox } - { "obj" object } -} -{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } -{ $see-also mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ; - -HELP: mailbox-get-all -{ $values { "mailbox" mailbox } - { "array" array } -} -{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } -{ $see-also mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ; - -HELP: while-mailbox-empty -{ $values { "mailbox" mailbox } - { "quot" "a quotation with stack effect " { $snippet "( -- )" } } -} -{ $description "Repeatedly call the quotation while there are no items in the mailbox." } -{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all mailbox-get? } ; - -HELP: mailbox-get? -{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } - { "mailbox" mailbox } - { "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." } -{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty } ; - HELP: send { $values { "message" object } { "thread" "a thread object" } @@ -95,8 +31,8 @@ HELP: spawn-linked { $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" } { $see-also spawn } ; -ARTICLE: { "concurrency" "mailboxes" } "Mailboxes" -"Each thread has an associated message queue. Other threads can place items on this queue by sending the thread a message. A thread can check its queue for messages, blocking if none are pending, and thread them as they are queued." +ARTICLE: { "concurrency" "messaging" } "Mailboxes" +"Each thread has an associated mailbox. Other threads can place items on this queue by sending the thread a message. A thread can check its mailbox for messages, blocking if none are pending, and thread them as they are queued." $nl "The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is." $nl @@ -104,14 +40,9 @@ $nl { $subsection send } "A thread can get a message from its queue:" { $subsection receive } -{ $subsection receive } +{ $subsection receive-timeout } { $subsection receive-if } -"Mailboxes can be created and used directly:" -{ $subsection mailbox } -{ $subsection } -{ $subsection mailbox-get } -{ $subsection mailbox-put } -{ $subsection mailbox-empty? } ; +{ $subsection receive-if-timeout } ; ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends" "The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:" @@ -133,8 +64,6 @@ ARTICLE: { "concurrency" "exceptions" } "Linked exceptions" { $code "[ 1 0 / \"This will not print\" print ] spawn" } "Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them." { $subsection spawn-linked } -"A more flexible version of the above deposits the error in an arbitary mailbox:" -{ $subsection spawn-linked-to } "This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:" { $code "[" " [ 1 0 / \"This will not print\" print ] spawn-linked drop" @@ -148,7 +77,7 @@ $nl "A concurrency oriented program is one in which multiple threades run simultaneously in a single Factor image or across multiple running Factor instances. The threades can communicate with each other by asynchronous message sends." $nl "Although threades can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code." -{ $subsection { "concurrency" "mailboxes" } } +{ $subsection { "concurrency" "messaging" } } { $subsection { "concurrency" "synchronous-sends" } } { $subsection { "concurrency" "exceptions" } } ; diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index 267fc7a8cd..5f241b77e3 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -3,48 +3,10 @@ ! USING: kernel threads vectors arrays sequences namespaces tools.test continuations dlists strings math words -match quotations concurrency.messaging ; +match quotations concurrency.messaging concurrency.mailboxes ; IN: temporary -[ ] [ mailbox mailbox-data dlist-delete-all ] unit-test - -[ V{ 1 2 3 } ] [ - 0 - - [ mailbox-get swap push ] in-thread - [ mailbox-get swap push ] in-thread - [ mailbox-get swap push ] in-thread - 1 over mailbox-put - 2 over mailbox-put - 3 swap mailbox-put -] unit-test - -[ 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 - 1 over mailbox-put - 2 over mailbox-put - 3 swap mailbox-put -] unit-test - -[ 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 - 1 over mailbox-put - "junk" over mailbox-put - [ 456 ] over mailbox-put - 3 over mailbox-put - "junk2" over mailbox-put - mailbox-get -] unit-test - +[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test [ "received" ] [ [ diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor index 53caed456c..97cd45190f 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/extra/concurrency/messaging/messaging.factor @@ -1,80 +1,11 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. ! -! Concurrency library for Factor based on Erlang/Termite style +! Concurrency library for Factor, based on Erlang/Termite style ! concurrency. +USING: kernel threads concurrency.mailboxes continuations +namespaces assocs random ; IN: concurrency.messaging -USING: dlists threads sequences continuations -namespaces random math quotations words kernel arrays assocs -init system concurrency.conditions ; - -TUPLE: mailbox threads data ; - -: ( -- mailbox ) - \ mailbox construct-boa ; - -: mailbox-empty? ( mailbox -- bool ) - mailbox-data dlist-empty? ; - -: mailbox-put ( obj mailbox -- ) - [ mailbox-data push-front ] keep - mailbox-threads notify-all ; - -r mailbox-threads r> "mailbox" wait - block-unless-pred - ] if ; inline - -: block-if-empty ( mailbox timeout -- mailbox ) - over mailbox-empty? [ - 2dup >r mailbox-threads r> "mailbox" wait - block-if-empty - ] [ - drop - ] if ; - -PRIVATE> - -: mailbox-peek ( mailbox -- obj ) - mailbox-data peek-back ; - -: mailbox-get-timeout ( mailbox timeout -- obj ) - block-if-empty mailbox-data pop-back ; - -: mailbox-get ( mailbox -- obj ) - f mailbox-get-timeout ; - -: mailbox-get-all-timeout ( mailbox timeout -- array ) - block-if-empty - [ dup mailbox-empty? ] - [ dup mailbox-data pop-back ] - [ ] unfold nip ; - -: mailbox-get-all ( mailbox -- array ) - f mailbox-get-all-timeout ; - -: while-mailbox-empty ( mailbox quot -- ) - over mailbox-empty? [ - dup >r swap slip r> while-mailbox-empty - ] [ - 2drop - ] if ; inline - -: mailbox-timeout-get? ( pred mailbox timeout -- obj ) - [ block-unless-pred ] 3keep drop - mailbox-data delete-node-if ; inline - -: mailbox-get? ( pred mailbox -- obj ) - f mailbox-timeout-get? ; inline - -TUPLE: linked error thread ; - -C: linked GENERIC: send ( message process -- ) @@ -86,25 +17,25 @@ GENERIC: send ( message process -- ) M: thread send ( message thread -- ) check-registered mailbox-of mailbox-put ; -: ?linked dup linked? [ rethrow ] when ; - -: mailbox self mailbox-of ; +: my-mailbox self mailbox-of ; : receive ( -- message ) - mailbox mailbox-get ?linked ; + my-mailbox mailbox-get ?linked ; + +: receive-timeout ( timeout -- message ) + my-mailbox swap mailbox-get-timeout ?linked ; : receive-if ( pred -- message ) - mailbox mailbox-get? ?linked ; inline + my-mailbox mailbox-get? ?linked ; inline + +: receive-if-timeout ( pred timeout -- message ) + my-mailbox swap mailbox-get-timeout? ?linked ; inline : rethrow-linked ( error process supervisor -- ) >r r> send ; -: spawn-linked-to ( quot name mailbox -- thread ) - [ >r r> mailbox-put ] curry - [ (spawn) ] keep ; - : spawn-linked ( quot name -- thread ) - mailbox spawn-linked-to ; + my-mailbox spawn-linked-to ; TUPLE: synchronous data sender tag ; @@ -116,17 +47,18 @@ TUPLE: reply data tag ; : ( data synchronous -- reply ) synchronous-tag \ reply construct-boa ; +: synchronous-reply? ( response synchronous -- ? ) + over reply? + [ >r reply-tag r> synchronous-tag = ] + [ 2drop f ] if ; + : send-synchronous ( message thread -- reply ) dup self eq? [ "Cannot synchronous send to myself" throw ] [ - >r dup r> send [ - over reply? [ - >r reply-tag r> synchronous-tag = - ] [ - 2drop f - ] if - ] curry receive-if reply-data + >r dup r> send + [ synchronous-reply? ] curry receive-if + reply-data ] if ; : reply-synchronous ( message synchronous -- ) @@ -139,18 +71,18 @@ TUPLE: reply data tag ; : register-process ( name process -- ) - swap remote-processes set-at ; + swap registered-processes set-at ; : unregister-process ( name -- ) - remote-processes delete-at ; + registered-processes delete-at ; : get-process ( name -- process ) - dup remote-processes at [ ] [ thread ] ?if ; + dup registered-processes at [ ] [ thread ] ?if ; -\ remote-processes global [ H{ } assoc-like ] change-at +\ registered-processes global [ H{ } assoc-like ] change-at diff --git a/extra/concurrency/promises/promises.factor b/extra/concurrency/promises/promises.factor index 6610a8c7ed..b7ccff7fa7 100755 --- a/extra/concurrency/promises/promises.factor +++ b/extra/concurrency/promises/promises.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: concurrency.messaging concurrency.messaging.private -kernel ; +USING: concurrency.mailboxes kernel continuations ; IN: concurrency.promises TUPLE: promise mailbox ; @@ -20,8 +19,7 @@ TUPLE: promise mailbox ; ] if ; : ?promise-timeout ( promise timeout -- result ) - >r promise-mailbox r> block-if-empty - mailbox-peek ?linked ; + >r promise-mailbox r> block-if-empty mailbox-peek ; : ?promise ( promise -- result ) f ?promise-timeout ; diff --git a/extra/concurrency/semaphores/semaphores-docs.factor b/extra/concurrency/semaphores/semaphores-docs.factor index 05ef6cc39e..7f8b9b017a 100755 --- a/extra/concurrency/semaphores/semaphores-docs.factor +++ b/extra/concurrency/semaphores/semaphores-docs.factor @@ -1,5 +1,5 @@ IN: concurrency.semaphores -USING: help.markup help.syntax kernel quotations ; +USING: help.markup help.syntax kernel quotations calendar ; HELP: semaphore { $class-description "The class of counting semaphores." } ; @@ -8,14 +8,23 @@ HELP: { $values { "n" "a non-negative integer" } { "semaphore" semaphore } } { $description "Creates a counting semaphore with the specified initial count." } ; +HELP: acquire-timeout +{ $values { "semaphore" semaphore } { "timeout" "a " { $link dt } " or " { $link f } } { "value" object } } +{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits a certain period of time, and if the semaphore still has not been released, throws an error." } +{ $errors "Throws an error if the timeout expires before the semaphore is released." } ; + HELP: acquire -{ $values { "semaphore" semaphore } { "timeout" "a timeout in milliseconds or " { $link f } } { "value" object } } -{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits up to that number of milliseconds for the semaphore to be released." } ; +{ $values { "semaphore" semaphore } { "value" object } } +{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, waits for it to be released." } ; HELP: release { $values { "semaphore" semaphore } } { $description "Increments a semaphore's count. If the count was previously zero, any threads waiting on the semaphore are woken up." } ; +HELP: with-semaphore-timeout +{ $values { "semaphore" semaphore } { "timeout" "a " { $link dt } " or " { $link f } } { "quot" quotation } } +{ $description "Calls the quotation with the semaphore held." } ; + HELP: with-semaphore { $values { "semaphore" semaphore } { "quot" quotation } } { $description "Calls the quotation with the semaphore held." } ; @@ -38,8 +47,10 @@ $nl { $subsection } "Unlike locks, where acquisition and release are always paired by a combinator, semaphores expose these operations directly and there is no requirement that they be performed in the same thread:" { $subsection acquire } +{ $subsection acquire-timeout } { $subsection release } -"A combinator which pairs acquisition and release:" -{ $subsection with-semaphore } ; +"Combinators which pair acquisition and release:" +{ $subsection with-semaphore } +{ $subsection with-semaphore-timeout } ; ABOUT: "concurrency.semaphores" diff --git a/extra/concurrency/semaphores/semaphores.factor b/extra/concurrency/semaphores/semaphores.factor index 413e491fdb..031614ea95 100755 --- a/extra/concurrency/semaphores/semaphores.factor +++ b/extra/concurrency/semaphores/semaphores.factor @@ -13,17 +13,21 @@ TUPLE: semaphore count threads ; : wait-to-acquire ( semaphore timeout -- ) >r semaphore-threads r> "semaphore" wait ; -: acquire ( semaphore timeout -- ) - dup semaphore-count zero? [ - wait-to-acquire - ] [ - drop - dup semaphore-count 1- swap set-semaphore-count - ] if ; +: acquire-timeout ( semaphore timeout -- ) + over semaphore-count zero? + [ dupd wait-to-acquire ] [ drop ] if + dup semaphore-count 1- swap set-semaphore-count ; + +: acquire ( semaphore -- ) + f acquire-timeout ; : release ( semaphore -- ) dup semaphore-count 1+ over set-semaphore-count semaphore-threads notify-1 ; +: with-semaphore-timeout ( semaphore timeout quot -- ) + pick rot acquire-timeout swap + [ release ] curry [ ] cleanup ; inline + : with-semaphore ( semaphore quot -- ) - over acquire [ release ] curry [ ] cleanup ; inline + over acquire swap [ release ] curry [ ] cleanup ; inline diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index fb60f6666d..f12e0180b1 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -99,6 +99,7 @@ $nl { $subsection "concurrency.combinators" } { $subsection "concurrency.promises" } { $subsection "concurrency.futures" } +{ $subsection "concurrency.mailboxes" } { $subsection "concurrency.messaging" } "Shared-state abstractions:" { $subsection "concurrency.locks" } diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 7945950acb..99ba045019 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files io.timeouts strings -splitting continuations assocs.lib ; +splitting continuations assocs.lib calendar ; IN: http.client : parse-host ( url -- host port ) diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 112bfc3673..a2f5c3474b 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io io.timeouts strings splitting threads http http.server.responders sequences prettyprint -io.server logging ; +io.server logging calendar ; IN: http.server diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor index 966383ae23..ef660a6f0d 100755 --- a/extra/io/timeouts/timeouts.factor +++ b/extra/io/timeouts/timeouts.factor @@ -17,7 +17,7 @@ GENERIC: timed-out ( obj -- ) M: object timed-out drop ; : queue-timeout ( obj timeout -- alarm ) - from-now f rot [ timed-out ] curry add-alarm ; + >r [ timed-out ] curry r> later ; : with-timeout ( obj quot -- ) over dup timeout dup [ diff --git a/extra/math/ranges/ranges.factor b/extra/math/ranges/ranges.factor old mode 100644 new mode 100755 index 83a95c312d..ade3b63a5c --- a/extra/math/ranges/ranges.factor +++ b/extra/math/ranges/ranges.factor @@ -1,10 +1,6 @@ USING: kernel layouts math namespaces sequences sequences.private ; IN: math.ranges -: >integer ( n -- i ) - dup most-negative-fixnum most-positive-fixnum between? - [ >fixnum ] [ >bignum ] if ; - TUPLE: range from length step ; : ( from to step -- range ) diff --git a/extra/models/models.factor b/extra/models/models.factor index f9d3f57123..fd84dd248f 100755 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -190,9 +190,9 @@ TUPLE: delay model timeout alarm ; delay-alarm [ cancel-alarm ] when* ; : start-delay ( delay -- ) - now over delay-timeout +dt f - pick [ f over set-delay-alarm update-delay-model ] curry - add-alarm swap set-delay-alarm ; + dup [ f over set-delay-alarm update-delay-model ] curry + over delay-timeout later + swap set-delay-alarm ; M: delay model-changed nip dup cancel-delay start-delay ; diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index a196173852..cf6d1a9ed9 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme @@ -88,6 +88,7 @@ TUPLE: repeat-button ; repeat-button H{ { T{ drag } [ button-clicked ] } + { T{ button-down } [ button-clicked ] } } set-gestures : ( label quot -- button ) diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index e9a24d702f..0edf82dbd1 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -114,8 +114,10 @@ SYMBOL: drag-timer : start-drag-timer ( -- ) hand-buttons get-global empty? [ - now 300 milliseconds +dt 100 milliseconds - [ drag-gesture ] add-alarm drag-timer get-global >box + [ drag-gesture ] + 300 milliseconds from-now + 100 milliseconds + add-alarm drag-timer get-global >box ] when ; : stop-drag-timer ( -- ) From fd9d3d39bb0eb7de847f528497d227a649798fa7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 22 Feb 2008 00:08:35 -0600 Subject: [PATCH 26/29] Fix typo --- extra/concurrency/count-downs/count-downs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/concurrency/count-downs/count-downs.factor b/extra/concurrency/count-downs/count-downs.factor index 61dd366c77..b1fa137bc4 100755 --- a/extra/concurrency/count-downs/count-downs.factor +++ b/extra/concurrency/count-downs/count-downs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: dlists kernel math concurrency.promises -concurrency.messaging ; +concurrency.mailboxes ; IN: concurrency.count-downs ! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html From e455dd036283393f60aa29f806dbbb340740846b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 22 Feb 2008 00:47:43 -0600 Subject: [PATCH 27/29] Fix ogg.player and space-invaders --- extra/ogg/player/player.factor | 2 +- extra/space-invaders/space-invaders.factor | 9 +++++---- 2 files changed, 6 insertions(+), 5 deletions(-) mode change 100644 => 100755 extra/ogg/player/player.factor diff --git a/extra/ogg/player/player.factor b/extra/ogg/player/player.factor old mode 100644 new mode 100755 index 518030ee4d..dae96dc0ea --- a/extra/ogg/player/player.factor +++ b/extra/ogg/player/player.factor @@ -149,7 +149,7 @@ HINTS: yuv>rgb byte-array byte-array ; dup player-gadget [ dup { player-td player-yuv } get-slots theora_decode_YUVout drop dup player-rgb over player-yuv yuv>rgb - dup player-gadget find-world dup draw-world + dup player-gadget find-world draw-world ] when ; : num-audio-buffers-processed ( player -- player n ) diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor index d992df4d8f..d66ffdc66e 100755 --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -3,8 +3,9 @@ ! USING: cpu.8080 cpu.8080.emulator openal math alien.c-types sequences kernel shuffle arrays io.files combinators ui.gestures -ui.gadgets ui.render opengl.gl system threads match -ui byte-arrays combinators.lib ; +ui.gadgets ui.render opengl.gl system match +ui byte-arrays combinators.lib qualified ; +QUALIFIED: threads IN: space-invaders TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ; @@ -337,7 +338,7 @@ M: space-invaders update-video ( value addr cpu -- ) : sync-frame ( millis -- millis ) #! Sleep until the time for the next frame arrives. 1000 60 / >fixnum + millis - dup 0 > - [ sleep ] [ drop yield ] if millis ; + [ threads:sleep ] [ drop threads:yield ] if millis ; : invaders-process ( millis gadget -- ) #! Run a space invaders gadget inside a @@ -356,7 +357,7 @@ M: invaders-gadget graft* ( gadget -- ) dup invaders-gadget-cpu init-sounds f over set-invaders-gadget-quit? [ millis swap invaders-process ] curry - "Space invaders" spawn drop ; + "Space invaders" threads:spawn drop ; M: invaders-gadget ungraft* ( gadget -- ) t swap set-invaders-gadget-quit? ; From ba60ab8c6a300718eb1fa719757d3f5eeeccea6a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 22 Feb 2008 00:59:39 -0600 Subject: [PATCH 28/29] factor-menus: untabify --- extra/factory/factory-menus | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/extra/factory/factory-menus b/extra/factory/factory-menus index fa72fa6c9a..35ee75e31b 100644 --- a/extra/factory/factory-menus +++ b/extra/factory/factory-menus @@ -25,14 +25,14 @@ apps-menu> not [ new-wm-menu >apps-menu ] when { { "Emacs" [ "emacs &" system drop ] } { "KMail" [ "kmail &" system drop ] } { "Akregator" [ "akregator &" system drop ] } - { "Amarok" [ "amarok &" system drop ] } - { "K3b" [ "k3b &" system drop ] } - { "xchat" [ "xchat &" system drop ] } + { "Amarok" [ "amarok &" system drop ] } + { "K3b" [ "k3b &" system drop ] } + { "xchat" [ "xchat &" system drop ] } { "Nautilus" [ "nautilus --no-desktop &" system drop ] } - { "synaptic" [ "gksudo synaptic &" system drop ] } + { "synaptic" [ "gksudo synaptic &" system drop ] } { "Volume control" [ "gnome-volume-control &" system drop ] } { "Azureus" [ "~/azureus/azureus &" system drop ] } - { "Xephyr" [ "Xephyr -host-cursor :1 &" system drop ] } + { "Xephyr" [ "Xephyr -host-cursor :1 &" system drop ] } { "Stop Xephyr" [ "pkill Xephyr &" system drop ] } { "Stop Firefox" [ "pkill firefox &" system drop ] } } apps-menu> set-menu-items @@ -95,8 +95,8 @@ factory-menu> not [ new-wm-menu >factory-menu ] when { { "Maximize" [ maximize ] } { "Maximize Vertical" [ maximize-vertical ] } { "Restore" [ restore ] } - { "Hide" [ minimize ] } - { "Tile Master" [ tile-master ] } + { "Hide" [ minimize ] } + { "Tile Master" [ tile-master ] } } factory-menu> set-menu-items @@ -106,17 +106,17 @@ factory-menu> set-menu-items ! VAR: root-menu { { "xterm" [ "urxvt -bd grey +sb &" system drop ] } - { "Firefox" [ "firefox &" system drop ] } - { "xclock" [ "xclock &" system drop ] } - { "Apps >" [ apps-menu> <- popup ] } + { "Firefox" [ "firefox &" system drop ] } + { "xclock" [ "xclock &" system drop ] } + { "Apps >" [ apps-menu> <- popup ] } { "Factor >" [ factor-menu> <- popup ] } { "Unmapped frames >" [ unmapped-frames-menu> <- popup ] } - { "Emacs >" [ emacs-menu> <- popup ] } - { "Mail >" [ mail-menu> <- popup ] } - { "onigirihouse" [ "xterm -e 'ssh dharmatech@onigirihouse.com' &" - system drop ] } - { "Edit menus" [ edit-factory-menus ] } + { "Emacs >" [ emacs-menu> <- popup ] } + { "Mail >" [ mail-menu> <- popup ] } + { "onigirihouse" [ "xterm -e 'ssh dharmatech@onigirihouse.com' &" + system drop ] } + { "Edit menus" [ edit-factory-menus ] } { "Reload menus" [ load-factory-menus ] } - { "Factory >" [ factory-menu> <- popup ] } + { "Factory >" [ factory-menu> <- popup ] } } root-menu> set-menu-items From aae3913b5936e9f80409cf3a8fe1cf69b5e37d3a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 22 Feb 2008 01:01:14 -0600 Subject: [PATCH 29/29] io.files: temp-dir -> temp-directory --- core/io/files/files.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 108ace4393..7dbe8c229e 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -155,10 +155,10 @@ M: pathname <=> [ pathname-string ] compare ; : with-file-appender ( path quot -- ) >r r> with-stream ; inline -: temp-dir ( -- path ) +: temp-directory ( -- path ) "temp" resource-path dup exists? not [ dup make-directory ] when ; -: temp-file ( name -- path ) temp-dir swap path+ ; \ No newline at end of file +: temp-file ( name -- path ) temp-directory swap path+ ; \ No newline at end of file